[Git][ghc/ghc][wip/haddock-iface-fixes] 2 commits: haddock: Keep track of warnings/deprecations from dependent packages in `InstalledInterface`
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Tue Jul 9 13:29:58 UTC 2024
Zubin pushed to branch wip/haddock-iface-fixes at Glasgow Haskell Compiler / GHC
Commits:
0ceea859 by Zubin Duggal at 2024-07-09T18:59:45+05:30
haddock: Keep track of warnings/deprecations from dependent packages in `InstalledInterface`
and use this to propagate these on items re-exported from dependent packages.
Fixes #25037
- - - - -
07405521 by Zubin Duggal at 2024-07-09T18:59:45+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
- - - - -
7 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.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.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.hs
=====================================
@@ -228,25 +228,28 @@ createIfaces verbosity modules flags instIfaceMap = do
-- Visit modules in that order
sortedMods = concatMap go $ topSortModuleGraph False modGraph Nothing
out verbosity normal "Haddock coverage:"
- (ifaces, _) <- foldM f ([], Map.empty) sortedMods
+ let inst_warning_map = Map.unions $ map instWarningMap (Map.elems instIfaceMap)
+ (ifaces, _, _) <- foldM f ([], Map.empty, inst_warning_map) sortedMods
return (reverse ifaces)
where
- f (ifaces, ifaceMap) modSummary = do
+ f (ifaces, ifaceMap, warningMap) modSummary = do
x <- {-# SCC processModule #-}
withTimingM "processModule" (const ()) $ do
- processModule verbosity modSummary flags ifaceMap instIfaceMap
+ processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap
return $ case x of
Just iface -> ( iface:ifaces
- , Map.insert (ifaceMod iface) iface ifaceMap )
+ , Map.insert (ifaceMod iface) iface ifaceMap
+ , Map.union (ifaceWarningMap iface) warningMap)
Nothing -> ( ifaces
- , ifaceMap ) -- Boot modules don't generate ifaces.
+ , ifaceMap
+ , warningMap ) -- Boot modules don't generate ifaces.
dropErr :: MaybeErr e a -> Maybe a
dropErr (Succeeded a) = Just a
dropErr (Failed _) = Nothing
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
-processModule verbosity modSummary flags ifaceMap instIfaceMap = do
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> WarningMap -> Ghc (Maybe Interface)
+processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modSummary) ++ "..."
hsc_env <- getSession
@@ -269,7 +272,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do
{-# SCC createInterface #-}
withTiming logger "createInterface" (const ()) $
runIfM (liftIO . fmap dropErr . lookupGlobal_maybe hsc_env) $
- createInterface1 flags unit_state modSummary mod_iface ifaceMap instIfaceMap insts
+ createInterface1 flags unit_state modSummary mod_iface ifaceMap instIfaceMap insts warningMap
let
(haddockable, haddocked) =
@@ -375,13 +378,13 @@ createOneShotIface verbosity flags instIfaceMap moduleNameStr = do
let hieFilePath = case res of
Found ml _ -> ml_hie_file ml
_ -> throwE "createOneShotIface: module not found"
-
+ let inst_warning_map = Map.unions $ map instWarningMap (Map.elems instIfaceMap)
!interface <- do
logger <- getLogger
{-# SCC createInterface #-}
withTiming logger "createInterface" (const ()) $
runIfM (liftIO . fmap dropErr . lookupGlobal_maybe hsc_env) $
- createInterface1' flags (hsc_units hsc_env) dflags' hieFilePath iface mempty instIfaceMap insts
+ createInterface1' flags (hsc_units hsc_env) dflags' hieFilePath iface mempty instIfaceMap insts inst_warning_map
pure [interface]
=====================================
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/Interface/Create.hs
=====================================
@@ -83,8 +83,9 @@ createInterface1
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
+ -> WarningMap
-> IfM m Interface
-createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instances, fam_instances) =
+createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instances, fam_instances) depWarnings =
let
ModSummary
{ -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
@@ -94,7 +95,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
, ms_location = modl
} = mod_sum
in
- createInterface1' flags unit_state ms_hspp_opts (ml_hie_file modl) mod_iface ifaces inst_ifaces (instances, fam_instances)
+ createInterface1' flags unit_state ms_hspp_opts (ml_hie_file modl) mod_iface ifaces inst_ifaces (instances, fam_instances) depWarnings
createInterface1'
:: MonadIO m
@@ -106,8 +107,9 @@ createInterface1'
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
+ -> WarningMap
-> IfM m Interface
-createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces (instances, fam_instances) = do
+createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces (instances, fam_instances) depWarnings = do
let
sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
mLanguage = language dflags
@@ -205,7 +207,7 @@ createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces
let
-- Warnings in this module and transitive warnings from dependent modules
transitiveWarnings :: Map Name (Doc Name)
- transitiveWarnings = Map.unions (warningMap : map ifaceWarningMap (Map.elems ifaces))
+ transitiveWarnings = Map.union warningMap depWarnings
export_items <-
mkExportItems
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Iface.Binary (getWithUserData, putSymbolTable)
import GHC.Iface.Type (IfaceType, putIfaceType)
import GHC.Types.Name.Cache
import GHC.Types.Unique
+import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Unit.State
import GHC.Utils.Binary
@@ -366,6 +367,8 @@ instance Binary InstalledInterface where
visExps
opts
fixMap
+ warnMap
+ locMap
) = do
put_ bh modu
put_ bh is_sig
@@ -376,6 +379,8 @@ instance Binary InstalledInterface where
put_ bh visExps
put_ bh opts
put_ bh fixMap
+ put_ bh warnMap
+ put_ bh locMap
get bh = do
modu <- get bh
@@ -387,6 +392,8 @@ instance Binary InstalledInterface where
visExps <- get bh
opts <- get bh
fixMap <- get bh
+ warnMap <- get bh
+ locMap <- get bh
return
( InstalledInterface
modu
@@ -399,6 +406,8 @@ instance Binary InstalledInterface where
visExps
opts
fixMap
+ warnMap
+ locMap
)
instance Binary DocOption where
@@ -758,3 +767,19 @@ instance Binary n => Binary (Wrap n) where
name <- get bh
return (Backticked name)
_ -> error "get Wrap: Bad h"
+
+instance Binary RealSrcSpan where
+ put_ bh sp = do
+ put_ bh (srcSpanFile sp)
+ put_ bh (srcSpanStartLine sp)
+ put_ bh (srcSpanStartCol sp)
+ put_ bh (srcSpanEndLine sp)
+ put_ bh (srcSpanEndCol sp)
+
+ get bh = do
+ fs <- get bh
+ sl <- get bh
+ sc <- get bh
+ el <- get bh
+ ec <- get bh
+ pure $ mkRealSrcSpan (mkRealSrcLoc fs sl sc) (mkRealSrcLoc fs el ec)
=====================================
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
@@ -166,6 +168,8 @@ data InstalledInterface = InstalledInterface
, instOptions :: [DocOption]
-- ^ 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'
@@ -182,6 +186,8 @@ toInstalledIface interface =
, instOptions = interface.ifaceOptions
, 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/-/compare/8980f4b5667fb549de4151c386d7f5784df3cfc9...0740552187f7e11b7af1d9e1d5f60bd9c042a875
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8980f4b5667fb549de4151c386d7f5784df3cfc9...0740552187f7e11b7af1d9e1d5f60bd9c042a875
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/20240709/23eda91c/attachment-0001.html>
More information about the ghc-commits
mailing list