[Git][ghc/ghc][wip/haddock-iface-fixes] haddock: Keep track of instance source locations in `InstalledInterface` and use this to add
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Mon Jul 15 08:56:51 UTC 2024
Zubin pushed to branch wip/haddock-iface-fixes at Glasgow Haskell Compiler / GHC
Commits:
e543027d by Zubin Duggal at 2024-07-15T14:24:19+05:30
haddock: Keep track of instance source locations in `InstalledInterface` and use this to add
source locations on out of package instances
Fixes #24929
- - - - -
5 changed files:
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -433,16 +433,17 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages
= Map.insert k srcNameUrl pkgSrcMap
| otherwise = pkgSrcMap
+ pkgSrcLMap = Map.map (hypSrcModuleUrlToLineFormat . hypSrcPkgUrlToModuleFormat)
+ $ Map.mapKeys moduleUnit extSrcMap
-- 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
, Just k <- pkgKey
- = Map.singleton k hypSrcModuleLineUrlFormat
+ = Map.insert k hypSrcModuleLineUrlFormat pkgSrcLMap
| Just path <- srcLEntity
, Just k <- pkgKey
- = Map.singleton k path
- | otherwise = Map.empty
+ = Map.insert k path pkgSrcLMap
+ | otherwise = pkgSrcLMap
sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
=====================================
@@ -14,6 +14,7 @@ module Haddock.Backends.Hyperlinker.Utils
, hypSrcModuleNameUrlFormat
, hypSrcModuleLineUrlFormat
, hypSrcModuleUrlToNameFormat
+ , hypSrcModuleUrlToLineFormat
, hypSrcPkgUrlToModuleFormat
, spliceURL
, spliceURL'
@@ -86,6 +87,9 @@ hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
hypSrcModuleUrlToNameFormat :: String -> String
hypSrcModuleUrlToNameFormat url = url ++ "#" ++ nameFormat
+hypSrcModuleUrlToLineFormat :: String -> String
+hypSrcModuleUrlToLineFormat url = url ++ "#" ++ lineFormat
+
hypSrcPkgUrlToModuleFormat :: String -> String
hypSrcPkgUrlToModuleFormat url = url </> moduleFormat
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
=====================================
@@ -143,10 +143,11 @@ attachInstances expInfo ifaces instIfaceMap isOneShot = do
attach (cls_insts, fam_insts, inst_map) iface = do
let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
getFixity = findFixity iface ifaceMap instIfaceMap
+ getInstLocIface name = Map.lookup name . instInstanceLocMap =<< Map.lookup (nameModule name) instIfaceMap
newItems <-
mapM
- (attachToExportItem cls_insts fam_insts inst_map expInfo getInstDoc getFixity)
+ (attachToExportItem cls_insts fam_insts inst_map expInfo getInstDoc getFixity getInstLocIface)
(ifaceExportItems iface)
let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface) fam_insts
return $
@@ -184,9 +185,11 @@ attachToExportItem
-- ^ how to lookup the doc of an instance
-> (Name -> Maybe Fixity)
-- ^ how to lookup a fixity
+ -> (Name -> Maybe RealSrcSpan)
+ -- ^ how to lookup definition spans for instances
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export =
+attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity getInstLocIface export =
case attachFixities export of
ExportDecl e@(ExportD{expDDecl = L eSpan (TyClD _ d)}) -> do
insts <-
@@ -267,12 +270,17 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export
-- spanName: attach the location to the name that is the same file as the instance location
spanName s (InstHead{ihdClsName = clsn}) (L instL instn) =
- let s1 = getSrcSpan s
+ let s1 = let orig_span = getSrcSpan s
+ in if isGoodSrcSpan orig_span
+ then orig_span
+ else case getInstLocIface s of
+ Nothing -> orig_span
+ Just rs -> RealSrcSpan rs mempty
sn =
if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
then instn
else clsn
- in L (getSrcSpan s) sn
+ in L s1 sn
-- spanName on Either
spanNameE s (Left e) _ = L (getSrcSpan s) (Left e)
spanNameE s (Right ok) linst =
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -36,6 +36,7 @@ module Haddock.InterfaceFile
, binaryInterfaceVersionCompatibility
) where
+import Data.Coerce (coerce)
import Data.Function ((&))
import Data.IORef
import Data.Map (Map)
@@ -367,6 +368,7 @@ instance Binary InstalledInterface where
opts
fixMap
warnMap
+ locMap
) = do
put_ bh modu
put_ bh is_sig
@@ -378,6 +380,7 @@ instance Binary InstalledInterface where
put_ bh opts
put_ bh fixMap
put_ bh warnMap
+ put_ bh (coerce @_ @(Map Name BinSpan) locMap)
get bh = do
modu <- get bh
@@ -390,6 +393,7 @@ instance Binary InstalledInterface where
opts <- get bh
fixMap <- get bh
warnMap <- get bh
+ locMap <- get bh
return
( InstalledInterface
modu
@@ -403,6 +407,7 @@ instance Binary InstalledInterface where
opts
fixMap
warnMap
+ (coerce @(Map Name BinSpan) locMap)
)
instance Binary DocOption where
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -48,16 +48,18 @@ import Control.Monad.Catch
import Control.Monad.State.Strict
import Data.Data (Data)
import Data.Map (Map)
+import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC
import qualified GHC.Data.Strict as Strict
import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Core.InstEnv (is_dfun_name)
import GHC.Types.Fixity (Fixity (..))
import GHC.Types.Name (stableNameCmp)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (RdrName (..))
-import GHC.Types.SrcLoc (BufPos (..), BufSpan (..))
+import GHC.Types.SrcLoc (BufPos (..), BufSpan (..), srcSpanToRealSrcSpan)
import GHC.Types.Var (Specificity)
import GHC.Utils.Outputable
@@ -167,6 +169,7 @@ data InstalledInterface = InstalledInterface
-- ^ Haddock options for this module (prune, ignore-exports, etc).
, instFixMap :: Map Name Fixity
, instWarningMap :: WarningMap
+ , instInstanceLocMap :: Map Name RealSrcSpan
}
-- | Convert an 'Interface' to an 'InstalledInterface'
@@ -184,6 +187,7 @@ toInstalledIface interface =
, instFixMap = interface.ifaceFixMap
, instDefMeths = interface.ifaceDefMeths
, instWarningMap = interface.ifaceWarningMap
+ , instInstanceLocMap = Map.fromList [(inst_name, loc) | i <- interface.ifaceInstances, let inst_name = is_dfun_name i, Just loc <- [srcSpanToRealSrcSpan (nameSrcSpan inst_name)]]
}
-- | A monad in which we create Haddock interfaces. Not to be confused with
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e543027da1ec3e4471f222afd6349063d8760d53
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e543027da1ec3e4471f222afd6349063d8760d53
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/20240715/f9ba76f5/attachment-0001.html>
More information about the ghc-commits
mailing list