coot/multiple packages (ghc-9.2) (#1418)

1 files changed, 58 insertions, 23 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8182707d..5b77a00f 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,6 +1,10 @@
-{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE Rank2Types          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+{-# OPTIONS_GHC -Wwarn           #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock
@@ -46,7 +50,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Data.Bifunctor (second)
 import Data.Foldable (forM_, foldl')
 import Data.Traversable (for)
-import Data.List (isPrefixOf)
+import Data.List (find, isPrefixOf, nub)
 import Control.Exception
 import Data.Maybe
 import Data.IORef
@@ -72,6 +76,7 @@ import GHC.Driver.Session hiding (projectVersion, verbosity)
 import GHC.Driver.Env
 import GHC.Utils.Error
 import GHC.Unit
+import GHC.Unit.State (lookupUnit)
 import GHC.Utils.Panic (handleGhcException)
 import GHC.Data.FastString
 
@@ -189,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
       mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
-      forM_ mIfaceFile $ \(_, ifaceFile) -> do
+      forM_ mIfaceFile $ \(_,_, ifaceFile) -> do
         putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
@@ -249,35 +254,49 @@ withGhc flags action = do
 
 
 readPackagesAndProcessModules :: [Flag] -> [String]
-                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+                              -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
     packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
-    let ifaceFiles = map snd packages
+    let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages
     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
 
     return (packages, ifaces, homeLinks)
 
 
 renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
-           -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+           -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO ()
 renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
-  updateHTMLXRefs pkgs
+  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) ->
+                          ( case baseUrl flags of
+                              Nothing  -> fst docPath
+                              Just url -> url </> packageName (ifUnitId ifaceFile)
+                          , ifaceFile)) pkgs)
   let
-    ifaceFiles = map snd pkgs
-    installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+    installedIfaces =
+      concatMap
+        (\(_, ifaceFilePath, ifaceFile)
+          -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)
+        pkgs
     extSrcMap = Map.fromList $ do
-      ((_, Just path), ifile) <- pkgs
+      ((_, Just path), _, ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
   render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+  where
+    -- get package name from unit-id
+    packageName :: Unit -> String
+    packageName unit =
+      case lookupUnit unit_state unit of
+        Nothing  -> show unit
+        Just pkg -> unitPackageNameString pkg
 
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-       -> [InstalledInterface] -> Map Module FilePath -> IO ()
+       -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
 render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
@@ -285,6 +304,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     unicode              = Flag_UseUnicode `elem` flags
     pretty               = Flag_PrettyHtml `elem` flags
     opt_wiki_urls        = wikiUrls          flags
+    opt_base_url         = baseUrl           flags
     opt_contents_url     = optContentsUrl    flags
     opt_index_url        = optIndexUrl       flags
     odir                 = outputDir         flags
@@ -298,7 +318,7 @@ 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 toInstalledIface ifaces ++ installedIfaces
+    allIfaces        = map toInstalledIface ifaces ++ map snd installedIfaces
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = fmap ifaceMod (listToMaybe ifaces)
@@ -343,7 +363,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) <- installedIfaces ]
 
     -- The user gives use base-4.9.0.0, but the InstalledInterface
     -- records the *wired in* identity base.  So untranslate it
@@ -366,6 +386,13 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
   themes   <- getThemes libDir flags >>= either bye return
 
   let withQuickjump = Flag_QuickJumpIndex `elem` flags
+      withBaseURL = isJust
+                  . find (\flag -> case flag of
+                           Flag_BaseURL base_url ->
+                             base_url /= "." && base_url /= "./"
+                           _ -> False
+                         )
+                  $ flags
 
   when (Flag_GenIndex `elem` flags) $ do
     withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
@@ -375,7 +402,8 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
                   allVisibleIfaces pretty
       return ()
 
-    copyHtmlBits odir libDir themes withQuickjump
+    unless withBaseURL $
+      copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
     withTiming logger dflags' "ppHtmlContents" (const ()) $ do
@@ -387,17 +415,24 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
       return ()
     copyHtmlBits odir libDir themes withQuickjump
 
+  when withQuickjump $ void $
+            ppJsonIndex odir sourceUrls' opt_wiki_urls
+                        unicode Nothing qual
+                        ifaces
+                        (nub $ map fst installedIfaces)
+
   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
+                  themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url
                   opt_contents_url opt_index_url unicode sincePkg qual
                   pretty withQuickjump
       return ()
-    copyHtmlBits odir libDir themes withQuickjump
-    writeHaddockMeta odir withQuickjump
+    unless withBaseURL $ do
+      copyHtmlBits odir libDir themes withQuickjump
+      writeHaddockMeta odir withQuickjump
 
   -- TODO: we throw away Meta for both Hoogle and LaTeX right now,
   -- might want to fix that if/when these two get some work on them
@@ -445,7 +480,7 @@ readInterfaceFiles :: MonadIO m
                    => NameCacheAccessor m
                    -> [(DocPaths, FilePath)]
                    -> Bool
-                   -> m [(DocPaths, InterfaceFile)]
+                   -> m [(DocPaths, FilePath, InterfaceFile)]
 readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
@@ -457,7 +492,7 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
           return Nothing
-        Right f -> return $ Just (paths, f)
+        Right f -> return (Just (paths, file, f))
 
 
 -------------------------------------------------------------------------------
@@ -678,12 +713,12 @@ hypSrcWarnings flags = do
     isSourceCssFlag _ = False
 
 
-updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
+updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)
   writeIORef html_xrefs_ref' (Map.fromList mapping')
   where
-    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
+    mapping = [ (instMod iface, html) | (html, ifaces) <- packages
               , iface <- ifInstalledIfaces ifaces ]
     mapping' = [ (moduleName m, html) | (m, html) <- mapping ]