[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
Thu Jul 4 09:01:23 UTC 2024
Zubin pushed to branch wip/haddock-iface-fixes at Glasgow Haskell Compiler / GHC
Commits:
c03db15b by Zubin Duggal at 2024-07-04T14:31:04+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
- - - - -
c49a84ba by Zubin Duggal at 2024-07-04T14:31:04+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
- - - - -
9 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
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug548.html
Changes:
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -430,16 +430,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
=====================================
@@ -217,25 +217,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
@@ -258,7 +261,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) =
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
=====================================
@@ -140,10 +140,11 @@ attachInstances expInfo ifaces instIfaceMap = 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 $
@@ -181,9 +182,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 <-
@@ -264,12 +267,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) = do
+createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instances, fam_instances) depWarnings = do
let
ModSummary
{ -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
@@ -191,7 +192,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
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
=====================================
utils/haddock/html-test/ref/Bug1004.html
=====================================
@@ -147,6 +147,8 @@
> f g :: k -> <a href="#" title="Data.Kind"
>Type</a
>)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc empty"
> </td
@@ -311,6 +313,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -385,6 +389,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -538,6 +544,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -590,6 +598,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -642,6 +652,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -742,6 +754,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -814,6 +828,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc empty"
> </td
@@ -868,6 +884,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -946,6 +964,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1040,6 +1060,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1098,6 +1120,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1168,6 +1192,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1226,6 +1252,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1274,6 +1302,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1470,6 +1500,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1556,6 +1588,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1624,6 +1658,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1706,6 +1742,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -1940,6 +1978,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc empty"
> </td
@@ -2096,6 +2136,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -2176,6 +2218,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -2246,6 +2290,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -2308,6 +2354,8 @@
> (<a href="#" title="Bug1004"
>Product</a
> f g a)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
=====================================
utils/haddock/html-test/ref/Bug548.html
=====================================
@@ -119,6 +119,8 @@
> -> <a href="#" title="Data.Kind"
>Type</a
>)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc empty"
> </td
@@ -259,6 +261,8 @@
> (<a href="#" title="Bug548"
>WrappedArrow</a
> a b)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -335,6 +339,8 @@
> (<a href="#" title="Bug548"
>WrappedArrow</a
> a b)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -427,6 +433,8 @@
> (<a href="#" title="Bug548"
>WrappedArrow</a
> a b)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -489,6 +497,8 @@
> (<a href="#" title="Bug548"
>WrappedArrow</a
> a b c)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc"
><p
@@ -723,6 +733,8 @@
> (<a href="#" title="Bug548"
>WrappedArrow</a
> a b c)</span
+ > <a href="#" class="selflink"
+ >#</a
></td
><td class="doc empty"
> </td
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7bbf9b48180c216d1c2c0bdff0dc4e6958342c70...c49a84ba439b5079936ff2eec0160c425a3671ac
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7bbf9b48180c216d1c2c0bdff0dc4e6958342c70...c49a84ba439b5079936ff2eec0160c425a3671ac
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/20240704/2ff37a96/attachment-0001.html>
More information about the ghc-commits
mailing list