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

* 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.

1 files changed, 78 insertions, 9 deletions

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