hadrian: Add --haddock-base-url option for specifying base-url when generating docs

The motiviation for this flag is to be able to produce documentation
which is suitable for uploading for hackage, ie, the cross-package links
work correctly.

There are basically three values you want to set this to:

* off - default, base_url = ../%pkg% which works for local browsing
* on - no argument , base_url = https:://hackage.haskell.org/package/%pkg%/docs - for hackage docs upload
* on - argument, for example, base_url = http://localhost:8080/package/%pkg%/docs for testing the documentation.

The `%pkg%` string is a template variable which is replaced with the
package identifier for the relevant package.

This is one step towards fixing #21749

1 files changed, 15 insertions, 4 deletions

diff --git a/hadrian/src/Settings/Builders/Haddock.hs b/hadrian/src/Settings/Builders/Haddock.hs
index 5d76b7ee1e..29032d0b78 100644
--- a/hadrian/src/Settings/Builders/Haddock.hs
+++ b/hadrian/src/Settings/Builders/Haddock.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Settings.Builders.Haddock (haddockBuilderArgs) where
 
 import Hadrian.Haskell.Cabal
@@ -8,6 +9,10 @@ import Packages
 import Rules.Documentation
 import Settings.Builders.Common
 import Settings.Builders.Ghc
+import Utilities
+import Context.Type as C
+import CommandLine
+import qualified Data.Text as T
 
 -- | Given a version string such as "2.16.2" produce an integer equivalent.
 versionToInt :: String -> Int
@@ -38,10 +43,13 @@ haddockBuilderArgs = mconcat
         context  <- getContext
         version  <- expr $ pkgVersion  pkg
         synopsis <- expr $ pkgSynopsis pkg
-        deps     <- getContextData depNames
+        trans_deps <- expr $ contextDependencies context
+        pkgs <- expr $ mapM (pkgIdentifier . C.package) $ trans_deps
         haddocks <- expr $ haddockDependencies context
         hVersion <- expr $ pkgVersion haddock
         statsDir <- expr $ haddockStatsFilesDir
+        baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
+        let baseUrl p = substituteTemplate baseUrlTemplate p
         ghcOpts  <- haddockGhcArgs
         mconcat
             [ arg "--verbosity=0"
@@ -59,12 +67,15 @@ haddockBuilderArgs = mconcat
             , arg $ "--optghc=-D__HADDOCK_VERSION__="
                     ++ show (versionToInt hVersion)
             , map ("--hide=" ++) <$> getContextData otherModules
-            , pure [ "--read-interface=../" ++ dep
-                     ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME},"
-                     ++ haddock | (dep, haddock) <- zip deps haddocks ]
+            , pure [ "--read-interface=../" ++ p
+                     ++ "," ++ baseUrl p ++ "/src/%{MODULE}.html#%{NAME},"
+                     ++ haddock | (p, haddock) <- zip pkgs haddocks ]
             , pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ]
             , getInputs
             , arg "+RTS"
             , arg $ "-t" ++ (statsDir -/- pkgName pkg ++ ".t")
             , arg "--machine-readable"
             , arg "-RTS" ] ]
+
+substituteTemplate :: String -> String -> String
+substituteTemplate baseTemplate pkgId = T.unpack . T.replace "%pkg%" (T.pack pkgId) . T.pack $ baseTemplate