diff options
Diffstat (limited to 'haddock-api/src')
-rw-r--r-- | haddock-api/src/Haddock.hs | 70 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 90 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 5 | ||||
-rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 87 |
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 |