aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-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
3 files changed, 146 insertions, 36 deletions
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-09-21 14:02:28 +0000