Merge pull request #6512 from commercialhaskell/fix6511

Fix #6511 Organise docs for components so that links work

doc/build_command.md

@@ -319,6 +319,23 @@ Unset the flag to disable building building hyperlinked source for Haddock.
 If the [`--haddock-for-hackage`](#-no-haddock-for-haddock-flag) flag is passed,
 this flag is ignored.
 
+### `--[no-]haddock-executables` flag
+
+Default: Disabled
+
+Set the flag to enable building Haddock documentation for executable components
+of packages.
+
+If the [`--haddock-for-hackage`](#-no-haddock-for-haddock-flag) flag is passed,
+this flag is ignored.
+
+!!! warning
+
+    Due to a bug, if there is more than one executable in a project package or
+    more than one project package with an executable, the Haddock documentation
+    for the `Main` module of one executable will overwrite the Haddock
+    documentation for others.
+
 ### `--[no-]haddock-internal` flag
 
 Default: Disabled

src/Stack/Build/Haddock.hs

@@ -23,16 +23,17 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Distribution.Text ( display )
 import           Path
-                   ( (</>), addExtension, dirname, fileExtension, fromAbsDir
-                   , fromAbsFile, fromRelDir, parent, parseRelDir, parseRelFile
+                   ( (</>), addExtension, dirname, fileExtension, filename
+                   , fromAbsDir, fromAbsFile, fromRelDir, parent, parseRelDir
+                   , parseRelFile
                    )
 import           Path.Extra
                    ( parseCollapsedAbsFile, toFilePathNoTrailingSep
                    , tryGetModificationTime
                    )
 import           Path.IO
-                   ( copyDirRecur', doesDirExist, doesFileExist, ensureDir
-                   , ignoringAbsence, listDir, removeDirRecur
+                   ( copyDirRecur, copyDirRecur', doesDirExist, doesFileExist
+                   , ensureDir, ignoringAbsence, listDir, removeDirRecur
                    )
 import qualified RIO.ByteString.Lazy as BL
 import           RIO.List ( intercalate, intersperse )
@@ -55,6 +56,7 @@ import           Stack.Types.Package
                    ( InstallLocation (..), LocalPackage (..), Package (..) )
 import qualified System.FilePath as FP
 import           Web.Browser ( openBrowser )
+import RIO.FilePath (dropTrailingPathSeparator)
 
 openHaddocksInBrowser ::
      HasTerm env
@@ -268,15 +270,52 @@ generateHaddockIndex descr bco dumpPackages docRelFP destDir = do
         srcInterfaceFile <- parseCollapsedAbsFile srcInterfaceFP
         let (PackageIdentifier name _) = dp.packageIdent
             srcInterfaceDir = parent srcInterfaceFile
-        -- It is possible that the *.haddock file specified by the
-        -- haddock-interfaces key for an installed package may not exist. For
-        -- example, with GHC 9.6.4 on Windows, there is no
-        --
-        -- ${pkgroot}/../doc/html/libraries/rts-1.0.2\rts.haddock
-        (srcInterfaceSubDirs, _) <- doesDirExist srcInterfaceDir >>= \case
-          True -> listDir srcInterfaceDir
-          False -> pure ([], [])
-        let destInterfaceRelFP =
+        compInterfaceDirsAndFiles <- do
+          -- It is possible that the *.haddock file specified by the
+          -- haddock-interfaces key for an installed package may not exist. For
+          -- example, with GHC 9.6.4 on Windows, there is no
+          --
+          -- ${pkgroot}/../doc/html/libraries/rts-1.0.2\rts.haddock
+          (srcInterfaceSubDirs, _) <- doesDirExist srcInterfaceDir >>= \case
+            True -> listDir srcInterfaceDir
+            False -> pure ([], [])
+          -- This assumes that Cabal (the library) `haddock --executables` for
+          -- component my-component of package my-package puts one *.haddock
+          -- file and associated files in directory:
+          --
+          -- my-package/my-component
+          --
+          -- Not all directories in directory my-package relate to components.
+          -- For example, my-package/src relates to the files for the
+          -- colourised code of the main library of package my-package.
+          let isCompInterfaceDir dir = do
+                (_, files) <- listDir dir
+                pure $ (dir, ) <$> F.find isInterface files
+               where
+                isInterface file = fileExtension file == Just ".haddock"
+          mapMaybeM isCompInterfaceDir srcInterfaceSubDirs
+        -- Lift a copy of the component's Haddock directory up to the same level
+        -- as the main library's Haddock directory. For compontent my-component
+        -- of package my-package we name the directory my-package_my-component.
+        let liftcompInterfaceDir dir file = do
+              let parentDir = parent dir
+                  parentName = dirname parentDir
+                  compName = dirname dir
+              uniqueName <- do
+                let parentName' =
+                      dropTrailingPathSeparator $ toFilePath parentName
+                    compName' =
+                      dropTrailingPathSeparator $ toFilePath compName
+                parseRelDir $ parentName' <> "_" <> compName'
+              let destCompDir = parent parentDir </> uniqueName
+                  destCompFile = destCompDir </> filename file
+              ignoringAbsence (removeDirRecur destCompDir)
+              ensureDir destCompDir
+              onException
+                (copyDirRecur dir destCompDir)
+                (ignoringAbsence (removeDirRecur destCompDir))
+              pure (destCompFile, uniqueName)
+            destInterfaceRelFP =
               docRelFP FP.</>
               packageIdentifierString dp.packageIdent FP.</>
               (packageNameString name FP.<.> "haddock")
@@ -285,29 +324,14 @@ generateHaddockIndex descr bco dumpPackages docRelFP destDir = do
             mkInterface :: Maybe FilePath -> FilePath -> String
             mkInterface mDocPath file =
               intercalate "," $ mcons mDocPath [file]
-            -- This assumes that Cabal (the library) `haddock --executables` for
-            -- component my-component of package my-package puts one *.haddock
-            -- file and associated files in directory:
-            --
-            -- my-package/my-component
-            --
-            -- Not all directories in directory my-package relate to components.
-            -- For example, my-package/src relates to the files for the
-            -- colourised code of the main library of package my-package.
-            compInterface :: Path Abs Dir -> IO (Maybe String)
-            compInterface dir = do
-              (_, files) <- listDir dir
-              pure $ toInterface <$> F.find isInterface files
-             where
-              toInterface file =
-                mkInterface compDocPathRelFP compSrcInterfaceFP
-               where
-                componentName = toFilePath $ dirname dir
-                compDocPathRelFP = (FP.</> componentName) <$> docPathRelFP
-                compSrcInterfaceFP = toFilePath file
-              isInterface file = fileExtension file == Just ".haddock"
+            compInterface :: (Path Abs Dir, Path Abs File) -> IO String
+            compInterface (dir, file) = do
+              (file', uniqueName) <- liftcompInterfaceDir dir file
+              let compDir = dropTrailingPathSeparator $ toFilePath uniqueName
+                  docDir = docRelFP FP.</> compDir
+              pure $ mkInterface (Just docDir) (toFilePath file')
             interfaces = mkInterface docPathRelFP srcInterfaceFP
-        compInterfaces <- catMaybes <$> forM srcInterfaceSubDirs compInterface
+        compInterfaces <- forM compInterfaceDirsAndFiles compInterface
         let readInterfaceArgs =
               "-i" : intersperse "-i" (interfaces : compInterfaces)
         destInterfaceFile <-