Merge pull request #1279 from 414owen/os/support-sublibrary-mods-sigs

feat: Add support for sublibrary module listings

Author: gbaz

datafiles/static/hackage.css

@@ -1146,6 +1146,14 @@ a.deprecated[href]:visited {
     color: #61B01E;
 }
 
+.lib-contents {
+  margin-left: 20px;
+}
+
+.lib-contents > h3 {
+  margin: 0.7em 0;
+}
+
 /* Paginator */
 #paginatorContainer {
   display: flex;

src/Distribution/Server/Packages/Render.hs

@@ -1,6 +1,7 @@
 -- TODO: Review and possibly move elsewhere. This code was part of the
 -- RecentPackages (formerly "Check") feature, but that caused some cyclic
 -- dependencies.
+{-# LANGUAGE TupleSections #-}
 module Distribution.Server.Packages.Render (
     -- * Package render
     PackageRender(..)
@@ -53,6 +54,7 @@ import Distribution.Utils.ShortText (fromShortText)
 
 import qualified Data.TarIndex as TarIndex
 import Data.TarIndex (TarIndex, TarEntryOffset)
+import Data.Bifunctor (first, Bifunctor (..))
 
 data ModSigIndex = ModSigIndex {
         modIndex :: ModuleForest,
@@ -64,10 +66,10 @@ data ModSigIndex = ModSigIndex {
 -- This is why some fields of PackageDescription are preprocessed, and others aren't.
 data PackageRender = PackageRender {
     rendPkgId        :: PackageIdentifier,
+    rendLibName      :: LibraryName -> String,
     rendDepends      :: [Dependency],
     rendExecNames    :: [String],
-    rendLibraryDeps  :: Maybe DependencyTree,
-    rendSublibraryDeps :: [(String, DependencyTree)],
+    rendLibraryDeps  :: [(LibraryName, DependencyTree)],
     rendExecutableDeps :: [(String, DependencyTree)],
     rendLicenseName  :: String,
     rendLicenseFiles :: [FilePath],
@@ -78,7 +80,7 @@ data PackageRender = PackageRender {
     -- to test if a module actually has a corresponding documentation HTML
     -- file we can link to.  If no 'TarIndex' is provided, it is assumed
     -- all links are dead.
-    rendModules      :: Maybe TarIndex -> Maybe ModSigIndex,
+    rendModules      :: Maybe TarIndex -> [(LibraryName, ModSigIndex)],
     rendHasTarball   :: Bool,
     rendChangeLog    :: Maybe (FilePath, ETag, TarEntryOffset, FilePath),
     rendReadme       :: Maybe (FilePath, ETag, TarEntryOffset, FilePath),
@@ -95,14 +97,13 @@ data PackageRender = PackageRender {
 
 doPackageRender :: Users.Users -> PkgInfo -> PackageRender
 doPackageRender users info = PackageRender
-    { rendPkgId        = pkgInfoId info
+    { rendPkgId        = packageId'
     , rendDepends      = flatDependencies genDesc
+    , rendLibName      = renderLibName
     , rendExecNames    = map (unUnqualComponentName . exeName) (executables flatDesc)
-    , rendLibraryDeps  = depTree libBuildInfo `fmap` condLibrary genDesc
     , rendExecutableDeps = (unUnqualComponentName *** depTree buildInfo)
                                 `map` condExecutables genDesc
-    , rendSublibraryDeps = (unUnqualComponentName *** depTree libBuildInfo)
-                                `map` condSubLibraries genDesc
+    , rendLibraryDeps = second (depTree libBuildInfo) <$> allCondLibs genDesc
     , rendLicenseName  = prettyShow (license desc) -- maybe make this a bit more human-readable
     , rendLicenseFiles = map getSymbolicPath $ licenseFiles desc
     , rendMaintainer   = case fromShortText $ maintainer desc of
@@ -144,17 +145,15 @@ doPackageRender users info = PackageRender
                                then Buildable
                                else NotBuildable
 
-    renderModules docindex
-      | Just lib <- library flatDesc
-      = let mod_ix = mkForest $ exposedModules lib
+    renderModules :: Maybe TarIndex -> [(LibraryName, ModSigIndex)]
+    renderModules docindex = flip fmap (allLibraries flatDesc) $ \lib ->
+      let mod_ix = mkForest $ exposedModules lib
                            -- Assumes that there is an HTML per reexport
                            ++ map moduleReexportName (reexportedModules lib)
                            ++ virtualModules (libBuildInfo lib)
-            sig_ix = mkForest $ signatures lib
-            mkForest = moduleForest . map (\m -> (m, moduleHasDocs docindex m))
-        in Just (ModSigIndex { modIndex = mod_ix, sigIndex = sig_ix })
-      | otherwise
-      = Nothing
+          sig_ix = mkForest $ signatures lib
+          mkForest = moduleForest . map (\m -> (m, moduleHasDocs docindex m))
+      in (libName lib, ModSigIndex { modIndex = mod_ix, sigIndex = sig_ix })
 
     moduleHasDocs :: Maybe TarIndex -> ModuleName -> Bool
     moduleHasDocs Nothing       = const False
@@ -172,6 +171,21 @@ doPackageRender users info = PackageRender
         loc <- repoLocation r
         return (ty, loc, r)
 
+    packageId' :: PackageIdentifier
+    packageId' = pkgInfoId info
+
+    packageName' :: String
+    packageName' = unPackageName $ pkgName packageId'
+
+    renderLibName :: LibraryName -> String
+    renderLibName LMainLibName = packageName'
+    renderLibName (LSubLibName name) =
+      packageName' ++ ":" ++ unUnqualComponentName name
+
+allCondLibs :: GenericPackageDescription -> [(LibraryName, CondTree ConfVar [Dependency] Library)]
+allCondLibs desc = maybeToList ((LMainLibName,) <$> condLibrary desc)
+  ++ (first LSubLibName <$> condSubLibraries desc)
+
 type DependencyTree = CondTree ConfVar [Dependency] IsBuildable
 
 data IsBuildable = Buildable

src/Distribution/Server/Pages/Package.hs

@@ -34,9 +34,10 @@ import Distribution.Utils.ShortText (fromShortText, ShortText)
 import Text.XHtml.Strict hiding (p, name, title, content)
 import qualified Text.XHtml.Strict
 
-import Data.Maybe               (fromMaybe, maybeToList, isJust, mapMaybe, catMaybes)
+import Data.Bool (bool)
+import Data.Maybe               (fromMaybe, isJust, mapMaybe, catMaybes)
 import Data.List                (intersperse, intercalate, partition)
-import Control.Arrow            (second)
+import Control.Arrow            (second, Arrow (..))
 import System.FilePath.Posix    ((</>), (<.>))
 
 import qualified Documentation.Haddock.Markup as Haddock
@@ -152,15 +153,19 @@ renderPackageFlags render docURL =
         whenNotNull xs a = if null xs then [] else a
 
 moduleSection :: PackageRender -> Maybe TarIndex -> URL -> Maybe PackageId -> Bool -> [Html]
-moduleSection render mdocIndex docURL mPkgId quickNav =
-    maybeToList $ fmap msect (rendModules render mdocIndex)
-  where msect ModSigIndex{ modIndex = m, sigIndex = s } = toHtml $
+moduleSection render mdocIndex docURL mPkgId quickNav = case renderedModules of
+  [(LMainLibName, mods)] -> [msect mods]
+  renderedLibs -> concatMap renderNamedLib renderedLibs
+
+  where msect (ModSigIndex{ modIndex = m, sigIndex = s }) =
+          let heading = bool h3 h2 containsSubLibraries in
+          toHtml $
             (if not (null s)
-                then [ h2 << "Signatures"
+                then [ heading << "Signatures"
                      , renderModuleForest docURL s ]
                 else []) ++
             (if not (null m)
-                then [ h2 << "Modules"] ++
+                then [ heading << "Modules"] ++
                      [renderDocIndexLink] ++
                      [renderModuleForest docURL m ]
                 else [])
@@ -184,6 +189,18 @@ moduleSection render mdocIndex docURL mPkgId quickNav =
             concatLinks [h]    = Just h
             concatLinks (h:hs) = (h +++) . ("] [" +++) <$> concatLinks hs
 
+        renderNamedLib :: (LibraryName, ModSigIndex) -> [Html]
+        renderNamedLib (name, mods) =
+          [ h2 << ("library " ++ rendLibName render name)
+          , thediv ! [theclass "lib-contents"] << msect mods
+          ]
+
+        containsSubLibraries :: Bool
+        containsSubLibraries = map fst renderedModules == [LMainLibName]
+
+        renderedModules :: [(LibraryName, ModSigIndex)]
+        renderedModules = rendModules render mdocIndex
+
 tabulate :: [(String, Html)] -> Html
 tabulate items = table ! [theclass "properties"] <<
         [tr << [th << t, td << d] | (t, d) <- items]
@@ -223,11 +240,8 @@ renderDetailedDependencies pkgRender =
     tabulate $ map (second (fromMaybe noDeps . render)) targets
   where
     targets :: [(String, DependencyTree)]
-    targets = maybeToList library
-        ++ rendSublibraryDeps pkgRender
+    targets = (first (rendLibName pkgRender) <$> rendLibraryDeps pkgRender)
         ++ rendExecutableDeps pkgRender
-      where
-        library = (\lib -> ("library", lib)) `fmap` rendLibraryDeps pkgRender
 
     noDeps = list [toHtml "No dependencies"]