aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs70
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs90
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs5
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs87
4 files changed, 199 insertions, 53 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 90aae0f6..7ed43ad2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -199,11 +200,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+ let packageInfo = PackageInfo { piPackageName =
+ fromMaybe (PackageName mempty) (optPackageName flags)
+ , piPackageVersion =
+ fromMaybe (makeVersion []) (optPackageVersion flags)
+ }
-- Dump an "interface file" (.haddock file), if requested.
forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
writeInterfaceFile path InterfaceFile {
ifInstalledIfaces = map toInstalledIface ifaces
+ , ifPackageInfo = packageInfo
, ifLinkEnv = homeLinks
}
@@ -277,9 +284,9 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
, ifaceFile)) pkgs)
let
installedIfaces =
- concatMap
+ map
(\(_, showModules, ifaceFilePath, ifaceFile)
- -> (showModules,ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)
+ -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile))
pkgs
extSrcMap = Map.fromList $ do
((_, Just path), _, _, ifile) <- pkgs
@@ -296,10 +303,16 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
-- | Render the interfaces with whatever backend is specified in the flags.
render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
- -> [(Visibility, FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
-render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
+ -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()
+render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
+ packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
+ $ optPackageName flags
+ , piPackageVersion = fromMaybe (makeVersion [])
+ $ optPackageVersion flags
+ }
+
title = fromMaybe "" (optTitle flags)
unicode = Flag_UseUnicode `elem` flags
pretty = Flag_PrettyHtml `elem` flags
@@ -317,10 +330,32 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
- -- /All/ visible interfaces including external package modules.
- allIfaces = map ((Visible,) . toInstalledIface) ifaces
- ++ map (\(showModules,_,iface) -> (showModules,iface)) installedIfaces
- allVisibleIfaces = [ i | (Visible, i) <- allIfaces, OptHide `notElem` instOptions i ]
+ -- /All/ interfaces including external package modules, grouped by
+ -- interface file (package).
+ allPackages :: [PackageInterfaces]
+ allPackages = [PackageInterfaces
+ { piPackageInfo = packageInfo
+ , piVisibility = Visible
+ , piInstalledInterfaces = map toInstalledIface ifaces
+ }]
+ ++ map snd packages
+
+ -- /All/ visible interfaces including external package modules, grouped by
+ -- interface file (package).
+ allVisiblePackages :: [PackageInterfaces]
+ allVisiblePackages = [ pinfo { piInstalledInterfaces =
+ filter (\i -> OptHide `notElem` instOptions i)
+ piInstalledInterfaces
+ }
+ | pinfo@PackageInterfaces
+ { piVisibility = Visible
+ , piInstalledInterfaces
+ } <- allPackages
+ ]
+
+ -- /All/ installed interfaces.
+ allInstalledIfaces :: [InstalledInterface]
+ allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages
pkgMod = fmap ifaceMod (listToMaybe ifaces)
pkgKey = fmap moduleUnit pkgMod
@@ -364,7 +399,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
installedMap :: Map Module InstalledInterface
- installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, _, iface) <- installedIfaces ]
+ installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ]
-- The user gives use base-4.9.0.0, but the InstalledInterface
-- records the *wired in* identity base. So untranslate it
@@ -400,7 +435,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
_ <- {-# SCC ppHtmlIndex #-}
ppHtmlIndex odir title pkgStr
themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
- allVisibleIfaces pretty
+ (concatMap piInstalledInterfaces allVisiblePackages) pretty
return ()
unless withBaseURL $
@@ -411,7 +446,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
_ <- {-# SCC ppHtmlContents #-}
ppHtmlContents unit_state odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty
+ allVisiblePackages True prologue pretty
sincePkg (makeContentsQual qual)
return ()
copyHtmlBits odir libDir themes withQuickjump
@@ -421,9 +456,9 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
unicode Nothing qual
ifaces
( nub
- . map (\(_,a,_) -> a)
- . filter (\(v,_,_) -> v == Visible)
- $ installedIfaces)
+ . map fst
+ . filter ((== Visible) . piVisibility . snd)
+ $ packages)
when (Flag_Html `elem` flags) $ do
withTiming logger dflags' "ppHtml" (const ()) $ do
@@ -431,8 +466,8 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
prologue
themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url
- opt_contents_url opt_index_url unicode sincePkg qual
- pretty withQuickjump
+ opt_contents_url opt_index_url unicode sincePkg packageInfo
+ qual pretty withQuickjump
return ()
unless withBaseURL $ do
copyHtmlBits odir libDir themes withQuickjump
@@ -496,7 +531,8 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
putStrLn (" " ++ err)
putStrLn "Skipping this interface."
return Nothing
- Right f -> return (Just (paths, showModules, file, f))
+ Right f ->
+ return (Just (paths, showModules, file, f ))
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 55783c67..3dc1e8da 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -28,7 +28,9 @@ import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
+import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo)
import Haddock.ModuleTree
+import Haddock.Options (Visibility (..))
import Haddock.Types
import Haddock.Version
import Haddock.Utils
@@ -78,6 +80,7 @@ ppHtml :: UnitState
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
-> Maybe String -- ^ Package name
+ -> PackageInfo -- ^ Package info
-> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> Bool -- ^ Also write Quickjump index
@@ -86,7 +89,7 @@ ppHtml :: UnitState
ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_base_url maybe_contents_url maybe_index_url unicode
- pkg qual debug withQuickjump = do
+ pkg packageInfo qual debug withQuickjump = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -94,7 +97,12 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
when (isNothing maybe_contents_url) $
ppHtmlContents state odir doctitle maybe_package
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
- (map toInstalledIface visible_ifaces ++ reexported_ifaces)
+ [PackageInterfaces
+ { piPackageInfo = packageInfo
+ , piVisibility = Visible
+ , piInstalledInterfaces = map toInstalledIface visible_ifaces
+ ++ reexported_ifaces
+ }]
False -- we don't want to display the packages in a single-package contents
prologue debug pkg (makeContentsQual qual)
@@ -277,30 +285,42 @@ ppHtmlContents
-> Maybe String
-> SourceURLs
-> WikiURLs
- -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
+ -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName)
-> Bool
-> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents state odir doctitle _maybe_package
themes mathjax_url maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
- let tree = mkModuleTree state showPkgs
- [(instMod iface, toInstalledDescription iface)
- | iface <- ifaces
- , not (instIsSig iface)]
- sig_tree = mkModuleTree state showPkgs
- [(instMod iface, toInstalledDescription iface)
- | iface <- ifaces
- , instIsSig iface]
+ maybe_source_url maybe_wiki_url packages showPkgs prologue debug pkg qual = do
+ let trees =
+ [ ( piPackageInfo pinfo
+ , mkModuleTree state showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- piInstalledInterfaces pinfo
+ , not (instIsSig iface)
+ ]
+ )
+ | pinfo <- packages
+ ]
+ sig_trees =
+ [ ( piPackageInfo pinfo
+ , mkModuleTree state showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- piInstalledInterfaces pinfo
+ , instIsSig iface
+ ]
+ )
+ | pinfo <- packages
+ ]
html =
headHtml doctitle themes mathjax_url Nothing +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
ppPrologue pkg qual doctitle prologue,
- ppSignatureTree pkg qual sig_tree,
- ppModuleTree pkg qual tree
+ ppSignatureTrees pkg qual sig_trees,
+ ppModuleTrees pkg qual trees
]
createDirectoryIfMissing True odir
writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
@@ -315,17 +335,37 @@ ppPrologue _ _ _ Nothing = noHtml
ppPrologue pkg qual title (Just doc) =
divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))
-
-ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
-ppSignatureTree _ _ [] = mempty
-ppSignatureTree pkg qual ts =
- divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
-
-
-ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
-ppModuleTree _ _ [] = mempty
-ppModuleTree pkg qual ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)
+ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
+ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
+ppSignatureTrees pkg qual [(info, ts)] =
+ divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
+ppSignatureTrees pkg qual tss =
+ divModuleList <<
+ (sectionName << "Signatures"
+ +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts
+ | (i, (info, ts)) <- zip [(1::Int)..] tss
+ ])
+
+ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
+ppSignatureTree _ _ _ _ [] = mempty
+ppSignatureTree pkg qual p info ts =
+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)
+
+ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
+ppModuleTrees _ _ tss | all (null . snd) tss = mempty
+ppModuleTrees pkg qual [(info, ts)] =
+ divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)
+ppModuleTrees pkg qual tss =
+ divPackageList <<
+ (sectionName << "Packages"
+ +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts
+ | (i, (info, ts)) <- zip [(1::Int)..] tss
+ ])
+
+ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
+ppModuleTree _ _ _ _ [] = mempty
+ppModuleTree pkg qual p info ts =
+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)
mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 8f04a21f..18405db8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.Layout (
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynopsis, divInterface,
- divIndex, divAlphabet, divModuleList, divContentsList,
+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList,
sectionName,
nonEmptySectionName,
@@ -81,7 +81,7 @@ nonEmptySectionName c
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynopsis, divInterface,
- divIndex, divAlphabet, divModuleList, divContentsList
+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList
:: Html -> Html
divPackageHeader = sectionDiv "package-header"
@@ -96,6 +96,7 @@ divInterface = sectionDiv "interface"
divIndex = sectionDiv "index"
divAlphabet = sectionDiv "alphabet"
divModuleList = sectionDiv "module-list"
+divPackageList = sectionDiv "module-list"
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index bd83e734..fa51bcbc 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -15,9 +16,10 @@
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
- InterfaceFile(..), ifUnitId, ifModule,
- readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
- writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
+ InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,
+ PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo, readInterfaceFile,
+ nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile,
+ binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where
@@ -30,9 +32,12 @@ import Data.IORef
import Data.List (mapAccumR)
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Version
import Data.Word
+import Text.ParserCombinators.ReadP (readP_to_S)
import GHC.Iface.Binary (getSymtabName, getDictFastString)
+import GHC.Unit.State
import GHC.Utils.Binary
import GHC.Data.FastMutInt
import GHC.Data.FastString
@@ -46,11 +51,43 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique
+import Haddock.Options (Visibility (..))
+
data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv,
+ -- | Package meta data. Currently it only consist of a package name, which
+ -- is not read from the interface file, but inferred from its name.
+ --
+ -- issue #
+ ifPackageInfo :: PackageInfo,
ifInstalledIfaces :: [InstalledInterface]
}
+data PackageInfo = PackageInfo {
+ piPackageName :: PackageName,
+ piPackageVersion :: Data.Version.Version
+}
+
+ppPackageInfo :: PackageInfo -> String
+ppPackageInfo (PackageInfo name version) | version == makeVersion []
+ = unpackFS (unPackageName name)
+ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version
+
+data PackageInterfaces = PackageInterfaces {
+ piPackageInfo :: PackageInfo,
+ piVisibility :: Visibility,
+ piInstalledInterfaces :: [InstalledInterface]
+}
+
+mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces
+mkPackageInterfaces piVisibility
+ InterfaceFile { ifPackageInfo
+ , ifInstalledIfaces
+ } =
+ PackageInterfaces { piPackageInfo = ifPackageInfo
+ , piVisibility
+ , piInstalledInterfaces = ifInstalledIfaces
+ }
ifModule :: InterfaceFile -> Module
ifModule if_ =
@@ -95,10 +132,10 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)
-binaryInterfaceVersion = 38
+binaryInterfaceVersion = 39
binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion]
+binaryInterfaceVersionCompatibility = [37, 38, binaryInterfaceVersion]
#elif defined(__HLINT__)
#else
#error Unsupported GHC version
@@ -139,7 +176,7 @@ writeInterfaceFile filename iface = do
let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
(putName bin_symtab)
(putFastString bin_dict)
- put_ bh iface
+ putInterfaceFile_ bh iface
-- write the symtab pointer at the front of the file
symtab_p <- tellBin bh
@@ -228,7 +265,7 @@ readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
(getDictFastString dict)
-- load the actual data
- iface <- liftIO $ get bh1
+ iface <- liftIO $ getInterfaceFile bh1 version
return (Right iface)
where
with_name_cache :: forall a.
@@ -372,16 +409,48 @@ instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
put_ bh m = put_ bh (Map.toList m)
get bh = fmap (Map.fromList) (get bh)
+instance Binary PackageInfo where
+ put_ bh PackageInfo { piPackageName, piPackageVersion } = do
+ put_ bh (unPackageName piPackageName)
+ put_ bh (showVersion piPackageVersion)
+ get bh = do
+ name <- PackageName <$> get bh
+ versionString <- get bh
+ let version = case readP_to_S parseVersion versionString of
+ [] -> makeVersion []
+ vs -> fst (last vs)
+ return $ PackageInfo name version
instance Binary InterfaceFile where
- put_ bh (InterfaceFile env ifaces) = do
+ put_ bh (InterfaceFile env info ifaces) = do
put_ bh env
+ put_ bh info
put_ bh ifaces
get bh = do
env <- get bh
+ info <- get bh
ifaces <- get bh
- return (InterfaceFile env ifaces)
+ return (InterfaceFile env info ifaces)
+
+
+putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO ()
+putInterfaceFile_ bh (InterfaceFile env info ifaces) = do
+ put_ bh env
+ put_ bh info
+ put_ bh ifaces
+
+getInterfaceFile :: BinHandle -> Word16 -> IO InterfaceFile
+getInterfaceFile bh v | v <= 38 = do
+ env <- get bh
+ let info = PackageInfo (PackageName mempty) (makeVersion [])
+ ifaces <- get bh
+ return (InterfaceFile env info ifaces)
+getInterfaceFile bh _ = do
+ env <- get bh
+ info <- get bh
+ ifaces <- get bh
+ return (InterfaceFile env info ifaces)
instance Binary InstalledInterface where
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 10:20:45 +0000