Render module tree per package in the content page (#1492)

coot · web-flow · commit c5a83df91b97 · 2022-06-07T06:09:40.000Z
* Render module tree per package in the content page

When rendering content page for multiple packages it is useful to split
the module tree per package.  Package names in this patch are inferred
from haddock's interface file names.

* Write PackageInfo into interface file

To keep interface file format backward compatible, instead of using
`Binary` instance for `InterfaceFile` we introduce functions to
serialise and deserialise, which depends on the interface file version.
diff --git 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,18 +456,18 @@ 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
       _ <- {-# SCC ppHtml #-}
            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
@@ -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,15 +89,20 @@ 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
 
   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
@@ -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
