Haddock.hs

{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.Build.Haddock
Description : Generate Haddock documentation.
License     : BSD-3-Clause

Generate Haddock documentation.
-}

module Stack.Build.Haddock
  ( generateDepsHaddockIndex
  , generateLocalHaddockIndex
  , generateSnapHaddockIndex
  , 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           Distribution.Text ( display )
import           Path
                   ( (</>), addExtension, dirname, fileExtension, filename
                   , fromAbsDir, fromAbsFile, fromRelDir, parent, parseRelDir
                   , parseRelFile
                   )
import           Path.Extra
                   ( parseCollapsedAbsFile, toFilePathNoTrailingSep
                   , tryGetModificationTime
                   )
import           Path.IO
                   ( copyDirRecur, copyDirRecur', doesDirExist, doesFileExist
                   , ensureDir, ignoringAbsence, listDir, removeDirRecur
                   )
import qualified RIO.ByteString.Lazy as BL
import           RIO.List ( intercalate, intersperse )
import           RIO.Process ( HasProcessContext, withWorkingDir )
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 (..), HaddockOpts (..) )
import           Stack.Types.BuildOptsCLI ( BuildOptsCLI (..), BuildSubset (BSOnlyDependencies, BSOnlySnapshot) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.InterfaceOpt ( InterfaceOpt (..) )
import           Stack.Types.Package
                   ( InstallLocation (..), LocalPackage (..), Package (..) )
import qualified System.FilePath as FP
import           Web.Browser ( openBrowser )
import RIO.FilePath (dropTrailingPathSeparator)

openHaddocksInBrowser ::
     HasTerm env
  => BaseConfigOpts
  -> Map PackageName (PackageIdentifier, InstallLocation)
  -- ^ Available packages and their locations for the current project
  -> Set PackageName
  -- ^ Build targets as determined by 'Stack.Build.Source.loadSourceMap'
  -> RIO env ()
openHaddocksInBrowser bco pkgLocations buildTargets = do
  let cliTargets = bco.buildOptsCLI.targetsCLI
      getDocIndex = do
        let localDocs = haddockIndexFile (localDepsDocDir bco)
        localExists <- doesFileExist localDocs
        if localExists
          then pure localDocs
          else do
            let snapDocs = haddockIndexFile (snapDocDir bco)
            snapExists <- doesFileExist snapDocs
            if snapExists
              then pure snapDocs
              else throwIO HaddockIndexNotFound
  docFile <-
    case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of
      ([_], [Just (pkgId, iloc)]) -> do
        pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId
        let docLocation =
              case iloc of
                Snap -> snapDocDir bco
                Local -> localDocDir bco
        let docFile = haddockIndexFile (docLocation </> pkgRelDir)
        exists <- doesFileExist docFile
        if exists
            then pure docFile
            else do
              prettyWarnL
                [ flow "Expected to find documentation at"
                , pretty docFile <> ","
                , flow "but that file is missing. Opening doc index instead."
                ]
              getDocIndex
      _ -> getDocIndex
  prettyInfo $ "Opening" <+> pretty docFile <+> "in the browser."
  void $ liftIO $ openBrowser (toFilePath docFile)

-- | Determine whether we should haddock for a package.
shouldHaddockPackage ::
     BuildOpts
  -> Set PackageName
     -- ^ Packages that we want to generate haddocks for in any case (whether or
     -- not we are going to generate haddocks for dependencies)
  -> PackageName
  -> Bool
shouldHaddockPackage bopts wanted name =
  if Set.member name wanted
    then bopts.buildHaddocks
    else shouldHaddockDeps bopts

-- | Determine whether to build haddocks for dependencies.
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps bopts = fromMaybe bopts.buildHaddocks bopts.haddockDeps

-- | Generate Haddock index and contents for project packages.
generateLocalHaddockIndex ::
     (HasCompiler env, HasProcessContext env, HasTerm env)
  => BaseConfigOpts
  -> Map GhcPkgId DumpPackage  -- ^ Local package dump
  -> [LocalPackage]
  -> RIO env ()
generateLocalHaddockIndex bco localDumpPkgs locals = do
  let dumpPackages =
        mapMaybe
          ( \LocalPackage {package = Package {name, version}} ->
              F.find
                ( \dp -> dp.packageIdent ==
                         PackageIdentifier name version
                )
                localDumpPkgs
          )
          locals
  generateHaddockIndex
    "project packages"
    bco
    dumpPackages
    "."
    (localDocDir bco)

-- | Generate Haddock index and contents for project packages and their
-- dependencies.
generateDepsHaddockIndex ::
     (HasCompiler env, HasProcessContext env, HasTerm env)
  => BaseConfigOpts
  -> Map GhcPkgId DumpPackage  -- ^ Global dump information
  -> Map GhcPkgId DumpPackage  -- ^ Snapshot dump information
  -> Map GhcPkgId DumpPackage  -- ^ Local dump information
  -> [LocalPackage]
  -> RIO env ()
generateDepsHaddockIndex bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do
  let deps = ( mapMaybe
                 (`lookupDumpPackage` allDumpPkgs)
                 . nubOrd
                 . findTransitiveDepends
                 . mapMaybe getGhcPkgId
             ) locals
      depDocDir = localDepsDocDir bco
  generateHaddockIndex
    "project packages and dependencies"
    bco
    deps
    ".."
    depDocDir
 where
  getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
  getGhcPkgId LocalPackage {package = Package {name, version}} =
    let pkgId = PackageIdentifier name version
        mdpPkg = F.find (\dp -> dp.packageIdent == pkgId) localDumpPkgs
    in  fmap (.ghcPkgId) mdpPkg
  findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
  findTransitiveDepends = (`go` HS.empty) . HS.fromList
   where
    go todo checked =
      case HS.toList todo of
        [] -> HS.toList checked
        (ghcPkgId:_) ->
          let deps = case lookupDumpPackage ghcPkgId allDumpPkgs of
                       Nothing -> HS.empty
                       Just pkgDP -> HS.fromList pkgDP.depends
              deps' = deps `HS.difference` checked
              todo' = HS.delete ghcPkgId (deps' `HS.union` todo)
              checked' = HS.insert ghcPkgId checked
          in  go todo' checked'
  allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs]

-- | Generate Haddock index and contents for all snapshot packages.
generateSnapHaddockIndex ::
     (HasCompiler env, HasProcessContext env, HasTerm env)
  => BaseConfigOpts
  -> Map GhcPkgId DumpPackage  -- ^ Global package dump
  -> Map GhcPkgId DumpPackage  -- ^ Snapshot package dump
  -> RIO env ()
generateSnapHaddockIndex bco globalDumpPkgs snapshotDumpPkgs =
  generateHaddockIndex
    "snapshot packages"
    bco
    (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs)
    "."
    (snapDocDir bco)

-- | Generate Haddock index and contents for specified packages.
generateHaddockIndex ::
     (HasCompiler env, HasProcessContext env, HasTerm env)
  => Text
  -> BaseConfigOpts
  -> [DumpPackage]
  -> FilePath
  -> Path Abs Dir
  -> RIO env ()
generateHaddockIndex descr bco dumpPackages docRelFP destDir = do
  ensureDir destDir
  interfaceOpts <-
    (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages
  unless (null interfaceOpts) $ do
    let destIndexFile = haddockIndexFile destDir
    eindexModTime <- liftIO (tryGetModificationTime destIndexFile)
    let needUpdate =
          case eindexModTime of
            Left _ -> True
            Right indexModTime ->
              or [ mt > indexModTime
                 | mt <- map (.srcInterfaceFileModTime) interfaceOpts
                 ]
        prettyDescr = style Current (fromString $ T.unpack descr)
    if needUpdate
      then do
        prettyInfo $
             fillSep
               [ flow "Updating Haddock index for"
               , prettyDescr
               , "in:"
               ]
          <> line
          <> pretty destIndexFile
        liftIO (mapM_ copyPkgDocs interfaceOpts)
        haddockExeName <- view $ compilerPathsL . to (toFilePath . (.haddock))
        withWorkingDir (toFilePath destDir) $ readProcessNull
          haddockExeName
          ( map
              (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep)
                 [bco.snapDB, bco.localDB]
              ++ bco.buildOpts.haddockOpts.additionalArgs
              ++ ["--gen-contents", "--gen-index"]
              ++ [x | xs <- map (.readInterfaceArgs) interfaceOpts, x <- xs]
          )
      else
        prettyInfo $
             fillSep
               [ flow "Haddock index for"
               , prettyDescr
               , flow "already up to date at:"
               ]
          <> line
          <> pretty destIndexFile
 where
  toInterfaceOpt ::
       DumpPackage
    -> IO (Maybe InterfaceOpt)
  toInterfaceOpt dp =
    case dp.haddockInterfaces of
      [] -> pure Nothing
      srcInterfaceFP:_ -> do
        srcInterfaceFile <- parseCollapsedAbsFile srcInterfaceFP
        let (PackageIdentifier name _) = dp.packageIdent
            srcInterfaceDir = parent srcInterfaceFile
        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.6 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")
            docPathRelFP =
              fmap ((docRelFP FP.</>) . FP.takeFileName) dp.haddockHtml
            mkInterface :: Maybe FilePath -> FilePath -> String
            mkInterface mDocPath file =
              intercalate "," $ mcons mDocPath [file]
            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 <- forM compInterfaceDirsAndFiles compInterface
        let readInterfaceArgs =
              "-i" : intersperse "-i" (interfaces : compInterfaces)
        destInterfaceFile <-
          parseCollapsedAbsFile (toFilePath destDir FP.</> destInterfaceRelFP)
        eSrcInterfaceFileModTime <- tryGetModificationTime srcInterfaceFile
        pure $
          case eSrcInterfaceFileModTime of
            Left _ -> Nothing
            Right srcInterfaceFileModTime ->
              Just InterfaceOpt
                { readInterfaceArgs
                , srcInterfaceFileModTime
                , srcInterfaceFile
                , destInterfaceFile
                }
  copyPkgDocs :: InterfaceOpt -> IO ()
  copyPkgDocs opts = do
  -- Copy dependencies' haddocks to documentation directory.  This way,
  -- relative @../$pkg-$ver@ links work and it's easy to upload docs to a web
  -- server or otherwise view them in a non-local-filesystem context. We copy
  -- instead of symlink for two reasons: (1) symlinks aren't reliably supported
  -- on Windows, and (2) the filesystem containing dependencies' docs may not be
  -- available where viewing the docs (e.g. if building in a Docker container).
    edestInterfaceModTime <- tryGetModificationTime opts.destInterfaceFile
    case edestInterfaceModTime of
      Left _ -> doCopy
      Right destInterfaceModTime
        | destInterfaceModTime < opts.srcInterfaceFileModTime -> doCopy
        | otherwise -> pure ()
   where
    doCopy = do
      ignoringAbsence (removeDirRecur destHtmlAbsDir)
      ensureDir destHtmlAbsDir
      onException
        (copyDirRecur' (parent opts.srcInterfaceFile) destHtmlAbsDir)
        (ignoringAbsence (removeDirRecur destHtmlAbsDir))
    destHtmlAbsDir = parent opts.destInterfaceFile

-- | Find first DumpPackage matching the GhcPkgId
lookupDumpPackage ::
     GhcPkgId
  -> [Map GhcPkgId DumpPackage]
  -> Maybe DumpPackage
lookupDumpPackage ghcPkgId dumpPkgs =
  listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs

-- | Path of haddock index file.
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile destDir = destDir </> relFileIndexHtml

-- | Path of project packages documentation directory.
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir bco = bco.localInstallRoot </> docDirSuffix

-- | Path of documentation directory for the dependencies of project packages
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir bco = localDocDir bco </> relDirAll

-- | Path of snapshot packages documentation directory.
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir bco = bco.snapInstallRoot </> docDirSuffix

generateLocalHaddockForHackageArchives ::
     (HasEnvConfig env, HasTerm env)
  => [LocalPackage]
  -> RIO env ()
generateLocalHaddockForHackageArchives lps = do
  buildSubset <- view $ envConfigL . to (.buildOptsCLI.buildSubset)
  let localsExcluded =
        buildSubset == BSOnlyDependencies || buildSubset == BSOnlySnapshot
  unless localsExcluded $
    forM_ lps $ \lp ->
      let pkg = lp.package
          pkgId = PackageIdentifier pkg.name pkg.version
          pkgDir = parent lp.cabalFP
      in  when lp.wanted $
            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
  tarGzFileCreated <- createTarGzFile tarGzFile docDir nameRelDir
  if tarGzFileCreated
    then
      prettyInfo $
           fillSep
             [ flow "Archive of Haddock documentation for Hackage for"
             , style Current (fromString pkgIdName)
             , flow "created at:"
             ]
        <> line
        <> pretty tarGzFile
    else
      prettyWarnL
        [ flow "No Haddock documentation for Hackage available for"
        , style Error (fromString pkgIdName) <> "."
        ]

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 Bool
createTarGzFile tar base dir = do
  dirExists <- doesDirExist $ base </> dir
  if dirExists
    then do
      entries <- liftIO $ Tar.pack base' [dir']
      if null entries
        then pure False
        else do
          ensureDir $ parent tar
          BL.writeFile tar' $ GZip.compress $ Tar.write entries
          pure True
    else pure False
 where
  base' = fromAbsDir base
  dir' = fromRelDir dir
  tar' = fromAbsFile tar