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

-- | Generate haddocks

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 :: forall env.
HasTerm env =>
BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
openHaddocksInBrowser BaseConfigOpts
bco Map PackageName (PackageIdentifier, InstallLocation)
pkgLocations Set PackageName
buildTargets = do
  let cliTargets :: [Text]
cliTargets = BaseConfigOpts
bco.buildOptsCLI.targetsCLI
      getDocIndex :: RIO env (Path Abs File)
getDocIndex = do
        let localDocs :: Path Abs File
localDocs = Path Abs Dir -> Path Abs File
haddockIndexFile (BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco)
        Bool
localExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
localDocs
        if Bool
localExists
          then Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
localDocs
          else do
            let snapDocs :: Path Abs File
snapDocs = Path Abs Dir -> Path Abs File
haddockIndexFile (BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco)
            Bool
snapExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
snapDocs
            if Bool
snapExists
              then Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
snapDocs
              else BuildException -> RIO env (Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BuildException
HaddockIndexNotFound
  Path Abs File
docFile <-
    case ([Text]
cliTargets, (PackageName -> Maybe (PackageIdentifier, InstallLocation))
-> [PackageName] -> [Maybe (PackageIdentifier, InstallLocation)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Maybe (PackageIdentifier, InstallLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map PackageName (PackageIdentifier, InstallLocation)
pkgLocations) (Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
buildTargets)) of
      ([Text
_], [Just (PackageIdentifier
pkgId, InstallLocation
iloc)]) -> do
        Path Rel Dir
pkgRelDir <- (FilePath -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (FilePath -> RIO env (Path Rel Dir))
-> (PackageIdentifier -> FilePath)
-> PackageIdentifier
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> FilePath
packageIdentifierString) PackageIdentifier
pkgId
        let docLocation :: Path Abs Dir
docLocation =
              case InstallLocation
iloc of
                InstallLocation
Snap -> BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco
                InstallLocation
Local -> BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco
        let docFile :: Path Abs File
docFile = Path Abs Dir -> Path Abs File
haddockIndexFile (Path Abs Dir
docLocation Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
pkgRelDir)
        Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
docFile
        if Bool
exists
            then Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
docFile
            else do
              [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                [ FilePath -> StyleDoc
flow FilePath
"Expected to find documentation at"
                , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
docFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
                , FilePath -> StyleDoc
flow FilePath
"but that file is missing. Opening doc index instead."
                ]
              RIO env (Path Abs File)
getDocIndex
      ([Text], [Maybe (PackageIdentifier, InstallLocation)])
_ -> RIO env (Path Abs File)
getDocIndex
  StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
docFile StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
  RIO env Bool -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env Bool -> RIO env ()) -> RIO env Bool -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
openBrowser (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
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 :: BuildOpts -> Set PackageName -> PackageName -> Bool
shouldHaddockPackage BuildOpts
bopts Set PackageName
wanted PackageName
name =
  if PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted
    then BuildOpts
bopts.buildHaddocks
    else BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts

-- | Determine whether to build haddocks for dependencies.

shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe BuildOpts
bopts.buildHaddocks BuildOpts
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 :: forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
locals = do
  let dumpPackages :: [DumpPackage]
dumpPackages =
        (LocalPackage -> Maybe DumpPackage)
-> [LocalPackage] -> [DumpPackage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          ( \LocalPackage {package :: LocalPackage -> Package
package = Package {PackageName
name :: PackageName
name :: Package -> PackageName
name, Version
version :: Version
version :: Package -> Version
version}} ->
              (DumpPackage -> Bool)
-> Map GhcPkgId DumpPackage -> Maybe DumpPackage
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find
                ( \DumpPackage
dp -> DumpPackage
dp.packageIdent PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
==
                         PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
                )
                Map GhcPkgId DumpPackage
localDumpPkgs
          )
          [LocalPackage]
locals
  Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
    Text
"project packages"
    BaseConfigOpts
bco
    [DumpPackage]
dumpPackages
    FilePath
"."
    (BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
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 :: forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
locals = do
  let deps :: [DumpPackage]
deps = ( (GhcPkgId -> Maybe DumpPackage) -> [GhcPkgId] -> [DumpPackage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                 (GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
`lookupDumpPackage` [Map GhcPkgId DumpPackage]
allDumpPkgs)
                 ([GhcPkgId] -> [DumpPackage])
-> ([LocalPackage] -> [GhcPkgId])
-> [LocalPackage]
-> [DumpPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcPkgId] -> [GhcPkgId]
forall a. Ord a => [a] -> [a]
nubOrd
                 ([GhcPkgId] -> [GhcPkgId])
-> ([LocalPackage] -> [GhcPkgId]) -> [LocalPackage] -> [GhcPkgId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends
                 ([GhcPkgId] -> [GhcPkgId])
-> ([LocalPackage] -> [GhcPkgId]) -> [LocalPackage] -> [GhcPkgId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalPackage -> Maybe GhcPkgId) -> [LocalPackage] -> [GhcPkgId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LocalPackage -> Maybe GhcPkgId
getGhcPkgId
             ) [LocalPackage]
locals
      depDocDir :: Path Abs Dir
depDocDir = BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco
  Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
    Text
"project packages and dependencies"
    BaseConfigOpts
bco
    [DumpPackage]
deps
    FilePath
".."
    Path Abs Dir
depDocDir
 where
  getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
  getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage {package :: LocalPackage -> Package
package = Package {PackageName
name :: Package -> PackageName
name :: PackageName
name, Version
version :: Package -> Version
version :: Version
version}} =
    let pkgId :: PackageIdentifier
pkgId = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
        mdpPkg :: Maybe DumpPackage
mdpPkg = (DumpPackage -> Bool)
-> Map GhcPkgId DumpPackage -> Maybe DumpPackage
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\DumpPackage
dp -> DumpPackage
dp.packageIdent PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId) Map GhcPkgId DumpPackage
localDumpPkgs
    in  (DumpPackage -> GhcPkgId) -> Maybe DumpPackage -> Maybe GhcPkgId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.ghcPkgId) Maybe DumpPackage
mdpPkg
  findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
  findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends = (HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
`go` HashSet GhcPkgId
forall a. HashSet a
HS.empty) (HashSet GhcPkgId -> [GhcPkgId])
-> ([GhcPkgId] -> HashSet GhcPkgId) -> [GhcPkgId] -> [GhcPkgId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcPkgId] -> HashSet GhcPkgId
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList
   where
    go :: HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
go HashSet GhcPkgId
todo HashSet GhcPkgId
checked =
      case HashSet GhcPkgId -> [GhcPkgId]
forall a. HashSet a -> [a]
HS.toList HashSet GhcPkgId
todo of
        [] -> HashSet GhcPkgId -> [GhcPkgId]
forall a. HashSet a -> [a]
HS.toList HashSet GhcPkgId
checked
        (GhcPkgId
ghcPkgId:[GhcPkgId]
_) ->
          let deps :: HashSet GhcPkgId
deps = case GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
lookupDumpPackage GhcPkgId
ghcPkgId [Map GhcPkgId DumpPackage]
allDumpPkgs of
                       Maybe DumpPackage
Nothing -> HashSet GhcPkgId
forall a. HashSet a
HS.empty
                       Just DumpPackage
pkgDP -> [GhcPkgId] -> HashSet GhcPkgId
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList DumpPackage
pkgDP.depends
              deps' :: HashSet GhcPkgId
deps' = HashSet GhcPkgId
deps HashSet GhcPkgId -> HashSet GhcPkgId -> HashSet GhcPkgId
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet GhcPkgId
checked
              todo' :: HashSet GhcPkgId
todo' = GhcPkgId -> HashSet GhcPkgId -> HashSet GhcPkgId
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.delete GhcPkgId
ghcPkgId (HashSet GhcPkgId
deps' HashSet GhcPkgId -> HashSet GhcPkgId -> HashSet GhcPkgId
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
`HS.union` HashSet GhcPkgId
todo)
              checked' :: HashSet GhcPkgId
checked' = GhcPkgId -> HashSet GhcPkgId -> HashSet GhcPkgId
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert GhcPkgId
ghcPkgId HashSet GhcPkgId
checked
          in  HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
go HashSet GhcPkgId
todo' HashSet GhcPkgId
checked'
  allDumpPkgs :: [Map GhcPkgId DumpPackage]
allDumpPkgs = [Map GhcPkgId DumpPackage
localDumpPkgs, Map GhcPkgId DumpPackage
snapshotDumpPkgs, Map GhcPkgId DumpPackage
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 :: forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs =
  Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
    Text
"snapshot packages"
    BaseConfigOpts
bco
    (Map GhcPkgId DumpPackage -> [DumpPackage]
forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
snapshotDumpPkgs [DumpPackage] -> [DumpPackage] -> [DumpPackage]
forall a. [a] -> [a] -> [a]
++ Map GhcPkgId DumpPackage -> [DumpPackage]
forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
globalDumpPkgs)
    FilePath
"."
    (BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
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 :: forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex Text
descr BaseConfigOpts
bco [DumpPackage]
dumpPackages FilePath
docRelFP Path Abs Dir
destDir = do
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
  [InterfaceOpt]
interfaceOpts <-
    (IO [InterfaceOpt] -> RIO env [InterfaceOpt]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [InterfaceOpt] -> RIO env [InterfaceOpt])
-> ([DumpPackage] -> IO [InterfaceOpt])
-> [DumpPackage]
-> RIO env [InterfaceOpt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([InterfaceOpt] -> [InterfaceOpt])
-> IO [InterfaceOpt] -> IO [InterfaceOpt]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [InterfaceOpt] -> [InterfaceOpt]
forall a. Ord a => [a] -> [a]
nubOrd (IO [InterfaceOpt] -> IO [InterfaceOpt])
-> ([DumpPackage] -> IO [InterfaceOpt])
-> [DumpPackage]
-> IO [InterfaceOpt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DumpPackage -> IO (Maybe InterfaceOpt))
-> [DumpPackage] -> IO [InterfaceOpt]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM DumpPackage -> IO (Maybe InterfaceOpt)
toInterfaceOpt) [DumpPackage]
dumpPackages
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InterfaceOpt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InterfaceOpt]
interfaceOpts) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    let destIndexFile :: Path Abs File
destIndexFile = Path Abs Dir -> Path Abs File
haddockIndexFile Path Abs Dir
destDir
    Either () UTCTime
eindexModTime <- IO (Either () UTCTime) -> RIO env (Either () UTCTime)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs File -> IO (Either () UTCTime)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
destIndexFile)
    let needUpdate :: Bool
needUpdate =
          case Either () UTCTime
eindexModTime of
            Left ()
_ -> Bool
True
            Right UTCTime
indexModTime ->
              [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ UTCTime
mt UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
indexModTime
                 | UTCTime
mt <- (InterfaceOpt -> UTCTime) -> [InterfaceOpt] -> [UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map (.srcInterfaceFileModTime) [InterfaceOpt]
interfaceOpts
                 ]
        prettyDescr :: StyleDoc
prettyDescr = Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
descr)
    if Bool
needUpdate
      then do
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               [ FilePath -> StyleDoc
flow FilePath
"Updating Haddock index for"
               , StyleDoc
prettyDescr
               , StyleDoc
"in:"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
destIndexFile
        IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((InterfaceOpt -> IO ()) -> [InterfaceOpt] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InterfaceOpt -> IO ()
copyPkgDocs [InterfaceOpt]
interfaceOpts)
        FilePath
haddockExeName <- Getting FilePath env FilePath -> RIO env FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting FilePath env FilePath -> RIO env FilePath)
-> Getting FilePath env FilePath -> RIO env FilePath
forall a b. (a -> b) -> a -> b
$ Getting FilePath env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL Getting FilePath env CompilerPaths
-> ((FilePath -> Const FilePath FilePath)
    -> CompilerPaths -> Const FilePath CompilerPaths)
-> Getting FilePath env FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> FilePath) -> SimpleGetter CompilerPaths FilePath
forall s a. (s -> a) -> SimpleGetter s a
to (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath)
-> (CompilerPaths -> Path Abs File) -> CompilerPaths -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.haddock))
        FilePath -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
destDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull
          FilePath
haddockExeName
          ( (Path Abs Dir -> FilePath) -> [Path Abs Dir] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map
              ((FilePath
"--optghc=-package-db=" ++ ) (FilePath -> FilePath)
-> (Path Abs Dir -> FilePath) -> Path Abs Dir -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep)
                 [BaseConfigOpts
bco.snapDB, BaseConfigOpts
bco.localDB]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ BaseConfigOpts
bco.buildOpts.haddockOpts.additionalArgs
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"--gen-contents", FilePath
"--gen-index"]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
x | [FilePath]
xs <- (InterfaceOpt -> [FilePath]) -> [InterfaceOpt] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (.readInterfaceArgs) [InterfaceOpt]
interfaceOpts, FilePath
x <- [FilePath]
xs]
          )
      else
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               [ FilePath -> StyleDoc
flow FilePath
"Haddock index for"
               , StyleDoc
prettyDescr
               , FilePath -> StyleDoc
flow FilePath
"already up to date at:"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
destIndexFile
 where
  toInterfaceOpt ::
       DumpPackage
    -> IO (Maybe InterfaceOpt)
  toInterfaceOpt :: DumpPackage -> IO (Maybe InterfaceOpt)
toInterfaceOpt DumpPackage
dp =
    case DumpPackage
dp.haddockInterfaces of
      [] -> Maybe InterfaceOpt -> IO (Maybe InterfaceOpt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InterfaceOpt
forall a. Maybe a
Nothing
      FilePath
srcInterfaceFP:[FilePath]
_ -> do
        Path Abs File
srcInterfaceFile <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
parseCollapsedAbsFile FilePath
srcInterfaceFP
        let (PackageIdentifier PackageName
name Version
_) = DumpPackage
dp.packageIdent
            srcInterfaceDir :: Path Abs Dir
srcInterfaceDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
srcInterfaceFile
        [(Path Abs Dir, Path Abs File)]
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

          ([Path Abs Dir]
srcInterfaceSubDirs, [Path Abs File]
_) <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
srcInterfaceDir IO Bool
-> (Bool -> IO ([Path Abs Dir], [Path Abs File]))
-> IO ([Path Abs Dir], [Path Abs File])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> Path Abs Dir -> IO ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
srcInterfaceDir
            Bool
False -> ([Path Abs Dir], [Path Abs File])
-> IO ([Path Abs Dir], [Path Abs File])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: Path b Dir -> m (Maybe (Path b Dir, Path Abs File))
isCompInterfaceDir Path b Dir
dir = do
                ([Path Abs Dir]
_, [Path Abs File]
files) <- Path b Dir -> m ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path b Dir
dir
                Maybe (Path b Dir, Path Abs File)
-> m (Maybe (Path b Dir, Path Abs File))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path b Dir, Path Abs File)
 -> m (Maybe (Path b Dir, Path Abs File)))
-> Maybe (Path b Dir, Path Abs File)
-> m (Maybe (Path b Dir, Path Abs File))
forall a b. (a -> b) -> a -> b
$ (Path b Dir
dir, ) (Path Abs File -> (Path b Dir, Path Abs File))
-> Maybe (Path Abs File) -> Maybe (Path b Dir, Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Abs File -> Bool) -> [Path Abs File] -> Maybe (Path Abs File)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find Path Abs File -> Bool
forall {b}. Path b File -> Bool
isInterface [Path Abs File]
files
               where
                isInterface :: Path b File -> Bool
isInterface Path b File
file = Path b File -> Maybe FilePath
forall (m :: * -> *) b. MonadThrow m => Path b File -> m FilePath
fileExtension Path b File
file Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
".haddock"
          (Path Abs Dir -> IO (Maybe (Path Abs Dir, Path Abs File)))
-> [Path Abs Dir] -> IO [(Path Abs Dir, Path Abs File)]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Path Abs Dir -> IO (Maybe (Path Abs Dir, Path Abs File))
forall {m :: * -> *} {b}.
MonadIO m =>
Path b Dir -> m (Maybe (Path b Dir, Path Abs File))
isCompInterfaceDir [Path Abs Dir]
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 :: Path b Dir -> Path b File -> m (Path b File, Path Rel Dir)
liftcompInterfaceDir Path b Dir
dir Path b File
file = do
              let parentDir :: Path b Dir
parentDir = Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
parent Path b Dir
dir
                  parentName :: Path Rel Dir
parentName = Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
parentDir
                  compName :: Path Rel Dir
compName = Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
dir
              Path Rel Dir
uniqueName <- do
                let parentName' :: FilePath
parentName' =
                      FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel Dir
parentName
                    compName' :: FilePath
compName' =
                      FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel Dir
compName
                FilePath -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (FilePath -> m (Path Rel Dir)) -> FilePath -> m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ FilePath
parentName' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"_" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
compName'
              let destCompDir :: Path b Dir
destCompDir = Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
parent Path b Dir
parentDir Path b Dir -> Path Rel Dir -> Path b Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
uniqueName
                  destCompFile :: Path b File
destCompFile = Path b Dir
destCompDir Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b File
file
              m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path b Dir -> m ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
destCompDir)
              Path b Dir -> m ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path b Dir
destCompDir
              m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
                (Path b Dir -> Path b Dir -> m ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur Path b Dir
dir Path b Dir
destCompDir)
                (m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path b Dir -> m ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
destCompDir))
              (Path b File, Path Rel Dir) -> m (Path b File, Path Rel Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path b File
destCompFile, Path Rel Dir
uniqueName)
            destInterfaceRelFP :: FilePath
destInterfaceRelFP =
              FilePath
docRelFP FilePath -> FilePath -> FilePath
FP.</>
              PackageIdentifier -> FilePath
packageIdentifierString DumpPackage
dp.packageIdent FilePath -> FilePath -> FilePath
FP.</>
              (PackageName -> FilePath
packageNameString PackageName
name FilePath -> FilePath -> FilePath
FP.<.> FilePath
"haddock")
            docPathRelFP :: Maybe FilePath
docPathRelFP =
              (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath
docRelFP FP.</>) (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.takeFileName) DumpPackage
dp.haddockHtml
            mkInterface :: Maybe FilePath -> FilePath -> String
            mkInterface :: Maybe FilePath -> FilePath -> FilePath
mkInterface Maybe FilePath
mDocPath FilePath
file =
              FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> [FilePath] -> [FilePath]
forall a. Maybe a -> [a] -> [a]
mcons Maybe FilePath
mDocPath [FilePath
file]
            compInterface :: (Path Abs Dir, Path Abs File) -> IO String
            compInterface :: (Path Abs Dir, Path Abs File) -> IO FilePath
compInterface (Path Abs Dir
dir, Path Abs File
file) = do
              (Path Abs File
file', Path Rel Dir
uniqueName) <- Path Abs Dir -> Path Abs File -> IO (Path Abs File, Path Rel Dir)
forall {m :: * -> *} {b} {b}.
(MonadCatch m, MonadUnliftIO m) =>
Path b Dir -> Path b File -> m (Path b File, Path Rel Dir)
liftcompInterfaceDir Path Abs Dir
dir Path Abs File
file
              let compDir :: FilePath
compDir = FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel Dir
uniqueName
                  docDir :: FilePath
docDir = FilePath
docRelFP FilePath -> FilePath -> FilePath
FP.</> FilePath
compDir
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath -> FilePath
mkInterface (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
docDir) (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
file')
            interfaces :: FilePath
interfaces = Maybe FilePath -> FilePath -> FilePath
mkInterface Maybe FilePath
docPathRelFP FilePath
srcInterfaceFP
        [FilePath]
compInterfaces <- [(Path Abs Dir, Path Abs File)]
-> ((Path Abs Dir, Path Abs File) -> IO FilePath) -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Path Abs Dir, Path Abs File)]
compInterfaceDirsAndFiles (Path Abs Dir, Path Abs File) -> IO FilePath
compInterface
        let readInterfaceArgs :: [FilePath]
readInterfaceArgs =
              FilePath
"-i" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"-i" (FilePath
interfaces FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
compInterfaces)
        Path Abs File
destInterfaceFile <-
          FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
parseCollapsedAbsFile (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
destDir FilePath -> FilePath -> FilePath
FP.</> FilePath
destInterfaceRelFP)
        Either () UTCTime
eSrcInterfaceFileModTime <- Path Abs File -> IO (Either () UTCTime)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceFile
        Maybe InterfaceOpt -> IO (Maybe InterfaceOpt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe InterfaceOpt -> IO (Maybe InterfaceOpt))
-> Maybe InterfaceOpt -> IO (Maybe InterfaceOpt)
forall a b. (a -> b) -> a -> b
$
          case Either () UTCTime
eSrcInterfaceFileModTime of
            Left ()
_ -> Maybe InterfaceOpt
forall a. Maybe a
Nothing
            Right UTCTime
srcInterfaceFileModTime ->
              InterfaceOpt -> Maybe InterfaceOpt
forall a. a -> Maybe a
Just InterfaceOpt
                { [FilePath]
readInterfaceArgs :: [FilePath]
readInterfaceArgs :: [FilePath]
readInterfaceArgs
                , UTCTime
srcInterfaceFileModTime :: UTCTime
srcInterfaceFileModTime :: UTCTime
srcInterfaceFileModTime
                , Path Abs File
srcInterfaceFile :: Path Abs File
srcInterfaceFile :: Path Abs File
srcInterfaceFile
                , Path Abs File
destInterfaceFile :: Path Abs File
destInterfaceFile :: Path Abs File
destInterfaceFile
                }
  copyPkgDocs :: InterfaceOpt -> IO ()
  copyPkgDocs :: InterfaceOpt -> IO ()
copyPkgDocs InterfaceOpt
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).

    Either () UTCTime
edestInterfaceModTime <- Path Abs File -> IO (Either () UTCTime)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime InterfaceOpt
opts.destInterfaceFile
    case Either () UTCTime
edestInterfaceModTime of
      Left ()
_ -> IO ()
doCopy
      Right UTCTime
destInterfaceModTime
        | UTCTime
destInterfaceModTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< InterfaceOpt
opts.srcInterfaceFileModTime -> IO ()
doCopy
        | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   where
    doCopy :: IO ()
doCopy = do
      IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir)
      Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destHtmlAbsDir
      IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
        (Path Abs Dir -> Path Abs Dir -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur' (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent InterfaceOpt
opts.srcInterfaceFile) Path Abs Dir
destHtmlAbsDir)
        (IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir))
    destHtmlAbsDir :: Path Abs Dir
destHtmlAbsDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent InterfaceOpt
opts.destInterfaceFile

-- | Find first DumpPackage matching the GhcPkgId

lookupDumpPackage :: GhcPkgId
                  -> [Map GhcPkgId DumpPackage]
                  -> Maybe DumpPackage
lookupDumpPackage :: GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
lookupDumpPackage GhcPkgId
ghcPkgId [Map GhcPkgId DumpPackage]
dumpPkgs =
  [DumpPackage] -> Maybe DumpPackage
forall a. [a] -> Maybe a
listToMaybe ([DumpPackage] -> Maybe DumpPackage)
-> [DumpPackage] -> Maybe DumpPackage
forall a b. (a -> b) -> a -> b
$ (Map GhcPkgId DumpPackage -> Maybe DumpPackage)
-> [Map GhcPkgId DumpPackage] -> [DumpPackage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GhcPkgId -> Map GhcPkgId DumpPackage -> Maybe DumpPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhcPkgId
ghcPkgId) [Map GhcPkgId DumpPackage]
dumpPkgs

-- | Path of haddock index file.

haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile Path Abs Dir
destDir = Path Abs Dir
destDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml

-- | Path of project packages documentation directory.

localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco = BaseConfigOpts
bco.localInstallRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix

-- | Path of documentation directory for the dependencies of project packages

localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirAll

-- | Path of snapshot packages documentation directory.

snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco = BaseConfigOpts
bco.snapInstallRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix

generateLocalHaddockForHackageArchives ::
     (HasEnvConfig env, HasTerm env)
  => [LocalPackage]
  -> RIO env ()
generateLocalHaddockForHackageArchives :: forall env.
(HasEnvConfig env, HasTerm env) =>
[LocalPackage] -> RIO env ()
generateLocalHaddockForHackageArchives [LocalPackage]
lps = do
  BuildSubset
buildSubset <- Getting BuildSubset env BuildSubset -> RIO env BuildSubset
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting BuildSubset env BuildSubset -> RIO env BuildSubset)
-> Getting BuildSubset env BuildSubset -> RIO env BuildSubset
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const BuildSubset EnvConfig)
-> env -> Const BuildSubset env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const BuildSubset EnvConfig)
 -> env -> Const BuildSubset env)
-> ((BuildSubset -> Const BuildSubset BuildSubset)
    -> EnvConfig -> Const BuildSubset EnvConfig)
-> Getting BuildSubset env BuildSubset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> BuildSubset) -> SimpleGetter EnvConfig BuildSubset
forall s a. (s -> a) -> SimpleGetter s a
to (.buildOptsCLI.buildSubset)
  let localsExcluded :: Bool
localsExcluded =
        BuildSubset
buildSubset BuildSubset -> BuildSubset -> Bool
forall a. Eq a => a -> a -> Bool
== BuildSubset
BSOnlyDependencies Bool -> Bool -> Bool
|| BuildSubset
buildSubset BuildSubset -> BuildSubset -> Bool
forall a. Eq a => a -> a -> Bool
== BuildSubset
BSOnlySnapshot
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
localsExcluded (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [LocalPackage] -> (LocalPackage -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LocalPackage]
lps ((LocalPackage -> RIO env ()) -> RIO env ())
-> (LocalPackage -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp ->
      let pkg :: Package
pkg = LocalPackage
lp.package
          pkgId :: PackageIdentifier
pkgId = PackageName -> Version -> PackageIdentifier
PackageIdentifier Package
pkg.name Package
pkg.version
          pkgDir :: Path Abs Dir
pkgDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent LocalPackage
lp.cabalFP
      in  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when LocalPackage
lp.wanted (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
            Path Abs Dir -> PackageIdentifier -> RIO env ()
forall env.
(HasEnvConfig env, HasTerm env) =>
Path Abs Dir -> PackageIdentifier -> RIO env ()
generateLocalHaddockForHackageArchive Path Abs Dir
pkgDir PackageIdentifier
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 :: forall env.
(HasEnvConfig env, HasTerm env) =>
Path Abs Dir -> PackageIdentifier -> RIO env ()
generateLocalHaddockForHackageArchive Path Abs Dir
pkgDir PackageIdentifier
pkgId = do
  Path Abs Dir
distDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
  let pkgIdName :: FilePath
pkgIdName = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
display PackageIdentifier
pkgId
      name :: FilePath
name = FilePath
pkgIdName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-docs"
      (Path Rel Dir
nameRelDir, Path Rel File
tarGzFileName) = (Path Rel Dir, Path Rel File)
-> Maybe (Path Rel Dir, Path Rel File)
-> (Path Rel Dir, Path Rel File)
forall a. a -> Maybe a -> a
fromMaybe
        (FilePath -> (Path Rel Dir, Path Rel File)
forall a. HasCallStack => FilePath -> a
error FilePath
"impossible")
        ( do Path Rel Dir
relDir <- FilePath -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir FilePath
name
             Path Rel File
nameRelFile <- FilePath -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
name
             Path Rel File
tarGz <- FilePath -> Path Rel File -> Maybe (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
FilePath -> Path b File -> m (Path b File)
addExtension FilePath
".gz" (Path Rel File -> Maybe (Path Rel File))
-> Maybe (Path Rel File) -> Maybe (Path Rel File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Path Rel File -> Maybe (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
FilePath -> Path b File -> m (Path b File)
addExtension FilePath
".tar" Path Rel File
nameRelFile
             (Path Rel Dir, Path Rel File)
-> Maybe (Path Rel Dir, Path Rel File)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Rel Dir
relDir, Path Rel File
tarGz)
        )
      tarGzFile :: Path Abs File
tarGzFile = Path Abs Dir
distDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
tarGzFileName
      docDir :: Path Abs Dir
docDir = Path Abs Dir
distDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
htmlDirSuffix
  Bool
tarGzFileCreated <- Path Abs File -> Path Abs Dir -> Path Rel Dir -> RIO env Bool
forall env.
Path Abs File -> Path Abs Dir -> Path Rel Dir -> RIO env Bool
createTarGzFile Path Abs File
tarGzFile Path Abs Dir
docDir Path Rel Dir
nameRelDir
  if Bool
tarGzFileCreated
    then
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ FilePath -> StyleDoc
flow FilePath
"Archive of Haddock documentation for Hackage for"
             , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
pkgIdName)
             , FilePath -> StyleDoc
flow FilePath
"created at:"
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tarGzFile
    else
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ FilePath -> StyleDoc
flow FilePath
"No Haddock documentation for Hackage available for"
        , Style -> StyleDoc -> StyleDoc
style Style
Error (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
pkgIdName) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]

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 :: forall env.
Path Abs File -> Path Abs Dir -> Path Rel Dir -> RIO env Bool
createTarGzFile Path Abs File
tar Path Abs Dir
base Path Rel Dir
dir = do
  Bool
dirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> RIO env Bool) -> Path Abs Dir -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
base Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
dir
  if Bool
dirExists
    then do
      [Entry]
entries <- IO [Entry] -> RIO env [Entry]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Entry] -> RIO env [Entry]) -> IO [Entry] -> RIO env [Entry]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO [Entry]
Tar.pack FilePath
base' [FilePath
dir']
      if [Entry] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Entry]
entries
        then Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        else do
          Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> RIO env ()) -> Path Abs Dir -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tar
          FilePath -> LByteString -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> LByteString -> m ()
BL.writeFile FilePath
tar' (LByteString -> RIO env ()) -> LByteString -> RIO env ()
forall a b. (a -> b) -> a -> b
$ LByteString -> LByteString
GZip.compress (LByteString -> LByteString) -> LByteString -> LByteString
forall a b. (a -> b) -> a -> b
$ [Entry] -> LByteString
Tar.write [Entry]
entries
          Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    else Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
 where
  base' :: FilePath
base' = Path Abs Dir -> FilePath
fromAbsDir Path Abs Dir
base
  dir' :: FilePath
dir' = Path Rel Dir -> FilePath
fromRelDir Path Rel Dir
dir
  tar' :: FilePath
tar' = Path Abs File -> FilePath
fromAbsFile Path Abs File
tar