Merge pull request #6283 from commercialhaskell/re6270-3

Re #6270 Step 3, create archive files of Haddock documentation

ChangeLog.md

@@ -33,7 +33,8 @@ Other enhancements:
   `1.24.0.0`.
 * Experimental: Add flag `--haddock-for-hackage` to Stack's `build` command
   (including the `haddock` synonym for `build --haddock`) to enable building
-  with flags to generate Haddock documentation suitable for upload to Hackage.
+  with flags to generate Haddock documentation, and an archive file, suitable
+  for upload to Hackage.
 
 Bug fixes:
 

doc/build_command.md

@@ -243,18 +243,35 @@ Unset the flag to disable building Haddock documentation for dependencies.
 Default: Disabled
 
 Set the flag to build with flags to generate Haddock documentation suitable for
-upload to Hackage.
+upload to Hackage. This requires Haddock documentation for dependencies to have
+been built previously (command `stack haddock`).
 
-For each local package, the generated Haddock documentation files are in
-directory `doc\html\<package_version>-docs\`, relative to Stack's dist work
-directory (see [`stack path --dist-dir`](path_command.md)).
+For each local package:
+
+* the generated Haddock documentation files are in directory
+  `doc\html\<package_version>-docs\`, relative to Stack's dist work directory
+  (see [`stack path --dist-dir`](path_command.md)); and
+* an archive of the `<package_version>-docs` directory and its contents is in
+  Stack's dist work directory.
 
 If the flag is set:
 
 * the [`--[no-]haddock-hyperlink-source`](#-no-haddock-hyperlink-source-flag)
-  flag is ignored and `--haddock-hyperlink-source` is implied; and
+  flag is ignored and `--haddock-hyperlink-source` is implied;
+* the [`--[no-]haddock-deps`](#-no-haddock-deps-flag) flag is ignored and
+  `--no-haddock-deps` is implied;
 * the [`--[no-]haddock-internal`](#-no-haddock-hyperlink-internal-flag) flag is
-  ignored and `--no-haddock-internal` is implied.
+  ignored and `--no-haddock-internal` is implied;
+* the [`--[no-]open`](#-no-open-flag) flag is ignored and `--no-open` is
+  implied; and
+* the [`--[no-]force-dirty`](#-no-force-dirty-flag) flag is ignored and
+  `--force-dirty` is implied.
+
+!!! info
+
+    Stack does not distinguish the building of Haddock documentation for Hackage
+    from the building of Haddock documentation generally. If the former has
+    occurred, use the `--force-dirty` flag.
 
 !!! note
 

src/Stack/Build/Execute.hs

@@ -98,8 +98,10 @@ import           Stack.Build.Cache
                    , writePackageProjectRoot, writeSetupConfigMod
                    )
 import           Stack.Build.Haddock
-                   ( generateDepsHaddockIndex, generateLocalHaddockIndex
-                   , generateSnapHaddockIndex, openHaddocksInBrowser
+                   ( generateDepsHaddockIndex
+                   , generateLocalHaddockForHackageArchives
+                   , generateLocalHaddockIndex, generateSnapHaddockIndex
+                   , openHaddocksInBrowser
                    )
 import           Stack.Build.Installed (  )
 import           Stack.Build.Source ( addUnlistedToBuildCache )
@@ -853,29 +855,33 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
   unless (null errs) $
     prettyThrowM $ ExecutionFailure errs
   when (boptsHaddock eeBuildOpts) $ do
-    snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)
-    localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)
-    generateLocalHaddockIndex eeBaseConfigOpts localDumpPkgs eeLocals
-    generateDepsHaddockIndex
-      eeBaseConfigOpts
-      eeGlobalDumpPkgs
-      snapshotDumpPkgs
-      localDumpPkgs
-      eeLocals
-    generateSnapHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs
-    when (boptsOpenHaddocks eeBuildOpts) $ do
-      let planPkgs, localPkgs, installedPkgs, availablePkgs
-            :: Map PackageName (PackageIdentifier, InstallLocation)
-          planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan)
-          localPkgs =
-            Map.fromList
-              [ (packageName p, (packageIdentifier p, Local))
-              | p <- map lpPackage eeLocals
-              ]
-          installedPkgs =
-            Map.map (swap . second installedPackageIdentifier) installedMap'
-          availablePkgs = Map.unions [planPkgs, localPkgs, installedPkgs]
-      openHaddocksInBrowser eeBaseConfigOpts availablePkgs (Map.keysSet targets)
+    if boptsHaddockForHackage eeBuildOpts
+      then
+        generateLocalHaddockForHackageArchives eeLocals
+      else do
+        snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)
+        localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)
+        generateLocalHaddockIndex eeBaseConfigOpts localDumpPkgs eeLocals
+        generateDepsHaddockIndex
+          eeBaseConfigOpts
+          eeGlobalDumpPkgs
+          snapshotDumpPkgs
+          localDumpPkgs
+          eeLocals
+        generateSnapHaddockIndex eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs
+        when (boptsOpenHaddocks eeBuildOpts) $ do
+          let planPkgs, localPkgs, installedPkgs, availablePkgs
+                :: Map PackageName (PackageIdentifier, InstallLocation)
+              planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan)
+              localPkgs =
+                Map.fromList
+                  [ (packageName p, (packageIdentifier p, Local))
+                  | p <- map lpPackage eeLocals
+                  ]
+              installedPkgs =
+                Map.map (swap . second installedPackageIdentifier) installedMap'
+              availablePkgs = Map.unions [planPkgs, localPkgs, installedPkgs]
+          openHaddocksInBrowser eeBaseConfigOpts availablePkgs (Map.keysSet targets)
  where
   installedMap' = Map.difference installedMap0
                 $ Map.fromList

src/Stack/Build/Haddock.hs

@@ -9,15 +9,22 @@ module Stack.Build.Haddock
   , openHaddocksInBrowser
   , shouldHaddockDeps
   , shouldHaddockPackage
+  , generateLocalHaddockForHackageArchives
   ) where
 
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Compression.GZip as GZip
 import qualified Data.Foldable as F
 import qualified Data.HashSet as HS
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Data.Time ( UTCTime )
-import           Path ( (</>), parent, parseRelDir )
+import           Distribution.Text ( display )
+import           Path
+                   ( (</>), addExtension, fromAbsDir, fromAbsFile, fromRelDir
+                   , parent, parseRelDir, parseRelFile
+                   )
 import           Path.Extra
                    ( parseCollapsedAbsFile, toFilePathNoTrailingSep
                    , tryGetModificationTime
@@ -26,17 +33,21 @@ import           Path.IO
                    ( copyDirRecur', doesFileExist, ensureDir, ignoringAbsence
                    , removeDirRecur
                    )
+import qualified RIO.ByteString.Lazy as BL
 import           RIO.List ( intercalate )
 import           RIO.Process ( HasProcessContext, withWorkingDir )
-import           Stack.Constants ( docDirSuffix, relDirAll, relFileIndexHtml )
-import           Stack.Prelude
+import           Stack.Constants
+                   ( docDirSuffix, htmlDirSuffix, relDirAll, relFileIndexHtml )
+import           Stack.Constants.Config ( distDirFromDir )
+import           Stack.Prelude hiding ( Display (..) )
 import           Stack.Types.Build.Exception ( BuildException (..) )
 import           Stack.Types.CompilerPaths
                    ( CompilerPaths (..), HasCompiler (..) )
 import           Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
 import           Stack.Types.BuildOpts
                    ( BuildOpts (..), BuildOptsCLI (..), HaddockOpts (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
+import           Stack.Types.EnvConfig ( HasEnvConfig (..) )
 import           Stack.Types.GhcPkgId ( GhcPkgId )
 import           Stack.Types.Package
                    ( InstallLocation (..), LocalPackage (..), Package (..) )
@@ -320,3 +331,64 @@ localDepsDocDir bco = localDocDir bco </> relDirAll
 -- | Path of snapshot packages documentation directory.
 snapDocDir :: BaseConfigOpts -> Path Abs Dir
 snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix
+
+generateLocalHaddockForHackageArchives ::
+     (HasEnvConfig env, HasTerm env)
+  => [LocalPackage]
+  -> RIO env ()
+generateLocalHaddockForHackageArchives =
+  mapM_
+    ( \lp ->
+        let pkg = lpPackage lp
+            pkgId = PackageIdentifier (packageName pkg) (packageVersion pkg)
+            pkgDir = parent (lpCabalFile lp)
+        in generateLocalHaddockForHackageArchive pkgDir pkgId
+    )
+
+-- | Generate an archive file containing local Haddock documentation for
+-- Hackage, in a form accepted by Hackage.
+generateLocalHaddockForHackageArchive ::
+     (HasEnvConfig env, HasTerm env)
+  => Path Abs Dir
+     -- ^ The package directory.
+  -> PackageIdentifier
+     -- ^ The package name and version.
+  -> RIO env ()
+generateLocalHaddockForHackageArchive pkgDir pkgId = do
+  distDir <- distDirFromDir pkgDir
+  let pkgIdName = display pkgId
+      name = pkgIdName <> "-docs"
+      (nameRelDir, tarGzFileName) = fromMaybe
+        (error "impossible")
+        ( do relDir <- parseRelDir name
+             nameRelFile <- parseRelFile name
+             tarGz <- addExtension ".gz" =<< addExtension ".tar" nameRelFile
+             pure (relDir, tarGz)
+        )
+      tarGzFile = distDir </> tarGzFileName
+      docDir = distDir </> docDirSuffix </> htmlDirSuffix
+  createTarGzFile tarGzFile docDir nameRelDir
+  prettyInfo $
+       fillSep
+         [ flow "Archive of Haddock documentation for Hackage for"
+         , style Current (fromString pkgIdName)
+         , flow "created at:"
+         ]
+    <> line
+    <> pretty tarGzFile
+
+createTarGzFile
+  :: Path Abs File
+  -- ^ Full path to archive file
+  -> Path Abs Dir
+  -- ^ Base directory
+  -> Path Rel Dir
+  -- ^ Directory to archive, relative to base directory
+  -> RIO env ()
+createTarGzFile tar base dir = do
+   entries <- liftIO $ Tar.pack base' [dir']
+   BL.writeFile tar' $ GZip.compress $ Tar.write entries
+ where
+  base' = fromAbsDir base
+  dir' = fromRelDir dir
+  tar' = fromAbsFile tar

src/Stack/Config/Build.hs

@@ -36,18 +36,23 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
        FirstTrue (if noStripping then Just False else Nothing))
   , boptsHaddock = fromFirstFalse buildMonoidHaddock
   , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts
-  , boptsOpenHaddocks = fromFirstFalse buildMonoidOpenHaddocks
-  , boptsHaddockDeps = getFirst buildMonoidHaddockDeps
-  , boptsHaddockInternal = fromFirstFalse buildMonoidHaddockInternal
+  , boptsOpenHaddocks =
+      not isHaddockFromHackage && fromFirstFalse buildMonoidOpenHaddocks
+  , boptsHaddockDeps = if isHaddockFromHackage
+      then Nothing
+      else getFirst buildMonoidHaddockDeps
+  , boptsHaddockInternal =
+      not isHaddockFromHackage && fromFirstFalse buildMonoidHaddockInternal
   , boptsHaddockHyperlinkSource =
-      fromFirstTrue buildMonoidHaddockHyperlinkSource
-  , boptsHaddockForHackage = fromFirstFalse buildMonoidHaddockForHackage
+      isHaddockFromHackage || fromFirstTrue buildMonoidHaddockHyperlinkSource
+  , boptsHaddockForHackage = isHaddockFromHackage
   , boptsInstallExes = fromFirstFalse buildMonoidInstallExes
   , boptsInstallCompilerTool = fromFirstFalse buildMonoidInstallCompilerTool
   , boptsPreFetch = fromFirstFalse buildMonoidPreFetch
   , boptsKeepGoing = getFirst buildMonoidKeepGoing
   , boptsKeepTmpFiles = fromFirstFalse buildMonoidKeepTmpFiles
-  , boptsForceDirty = fromFirstFalse buildMonoidForceDirty
+  , boptsForceDirty =
+      isHaddockFromHackage || fromFirstFalse buildMonoidForceDirty
   , boptsTests = fromFirstFalse buildMonoidTests
   , boptsTestOpts =
       testOptsFromMonoid buildMonoidTestOpts additionalArgs
@@ -64,6 +69,7 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
   , boptsDdumpDir = getFirst buildMonoidDdumpDir
   }
  where
+  isHaddockFromHackage = fromFirstFalse buildMonoidHaddockForHackage
   -- These options are not directly used in bopts, instead they
   -- transform other options.
   tracing = getAny buildMonoidTrace

src/Stack/Constants.hs

@@ -71,6 +71,7 @@ module Stack.Constants
   , relDirLoadedSnapshotCache
   , bindirSuffix
   , docDirSuffix
+  , htmlDirSuffix
   , relDirHpc
   , relDirLib
   , relDirShare
@@ -452,6 +453,10 @@ bindirSuffix = relDirBin
 docDirSuffix :: Path Rel Dir
 docDirSuffix = $(mkRelDir "doc")
 
+-- | Suffix applied to a path to get the @html@ directory.
+htmlDirSuffix :: Path Rel Dir
+htmlDirSuffix = $(mkRelDir "html")
+
 relDirHpc :: Path Rel Dir
 relDirHpc = $(mkRelDir "hpc")