{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}

-- | Generate haddocks

module Stack.Build.Haddock
    ( generateLocalHaddockIndex
    , generateDepsHaddockIndex
    , generateSnapHaddockIndex
    , openHaddocksInBrowser
    , shouldHaddockPackage
    , shouldHaddockDeps
    ) where

import           Stack.Prelude
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           Data.Time (UTCTime)
import           Path
import           Path.Extra
import           Path.IO
import           RIO.List (intercalate)
import           RIO.PrettyPrint
import           Stack.Constants
import           Stack.PackageDump
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.Package
import qualified System.FilePath as FP
import           RIO.Process
import           Web.Browser (openBrowser)

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 = (BuildOptsCLI -> [Text]
boptsCLITargets forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI) BaseConfigOpts
bco
        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 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
localDocs
            if Bool
localExists
                then forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
snapDocs
                    if Bool
snapExists
                        then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
snapDocs
                        else forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No local or snapshot doc index found to open."
    Path Abs File
docFile <-
        case ([Text]
cliTargets, forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map PackageName (PackageIdentifier, InstallLocation)
pkgLocations) (forall a. Set a -> [a]
Set.toList Set PackageName
buildTargets)) of
            ([Text
_], [Just (PackageIdentifier
pkgId, InstallLocation
iloc)]) -> do
                Path Rel Dir
pkgRelDir <- (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
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 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
pkgRelDir)
                Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
docFile
                if Bool
exists
                    then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
docFile
                    else do
                        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
                            Utf8Builder
"Expected to find documentation at " forall a. Semigroup a => a -> a -> a
<>
                            forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
docFile) forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
", 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
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
docFile StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
    Bool
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
openBrowser (forall b t. Path b t -> String
toFilePath Path Abs File
docFile)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 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 forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted
        then BuildOpts -> Bool
boptsHaddock BuildOpts
bopts
        else BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts

-- | Determine whether to build haddocks for dependencies.

shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts = forall a. a -> Maybe a -> a
fromMaybe (BuildOpts -> Bool
boptsHaddock BuildOpts
bopts) (BuildOpts -> Maybe Bool
boptsHaddockDeps BuildOpts
bopts)

-- | Generate Haddock index and contents for local packages.

generateLocalHaddockIndex
    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)
    => BaseConfigOpts
    -> Map GhcPkgId DumpPackage  -- ^ Local package dump

    -> [LocalPackage]
    -> RIO env ()
generateLocalHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
locals = do
    let dumpPackages :: [DumpPackage]
dumpPackages =
            forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                (\LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{Bool
[Text]
Maybe (Map PackageName VersionRange)
Either License License
Set Text
Set PackageName
Set ExeName
Map Text TestSuiteInterface
Map FlagName Bool
Map PackageName DepValue
Version
PackageName
CabalSpecVersion
BuildType
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: Package -> CabalSpecVersion
packageSetupDeps :: Package -> Maybe (Map PackageName VersionRange)
packageBuildType :: Package -> BuildType
packageHasExposedModules :: Package -> Bool
packageOpts :: Package -> GetPackageOpts
packageExes :: Package -> Set Text
packageBenchmarks :: Package -> Set Text
packageTests :: Package -> Map Text TestSuiteInterface
packageInternalLibraries :: Package -> Set Text
packageLibraries :: Package -> PackageLibraries
packageDefaultFlags :: Package -> Map FlagName Bool
packageFlags :: Package -> Map FlagName Bool
packageCabalConfigOpts :: Package -> [Text]
packageGhcOptions :: Package -> [Text]
packageAllDeps :: Package -> Set PackageName
packageUnknownTools :: Package -> Set ExeName
packageDeps :: Package -> Map PackageName DepValue
packageFiles :: Package -> GetPackageFiles
packageLicense :: Package -> Either License License
packageVersion :: Package -> Version
packageName :: Package -> PackageName
packageCabalSpec :: CabalSpecVersion
packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageBuildType :: BuildType
packageHasExposedModules :: Bool
packageOpts :: GetPackageOpts
packageExes :: Set Text
packageBenchmarks :: Set Text
packageTests :: Map Text TestSuiteInterface
packageInternalLibraries :: Set Text
packageLibraries :: PackageLibraries
packageDefaultFlags :: Map FlagName Bool
packageFlags :: Map FlagName Bool
packageCabalConfigOpts :: [Text]
packageGhcOptions :: [Text]
packageAllDeps :: Set PackageName
packageUnknownTools :: Set ExeName
packageDeps :: Map PackageName DepValue
packageFiles :: GetPackageFiles
packageLicense :: Either License License
packageVersion :: Version
packageName :: PackageName
..}} ->
                    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find
                        (\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp forall a. Eq a => a -> a -> Bool
== PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
packageName Version
packageVersion)
                        Map GhcPkgId DumpPackage
localDumpPkgs)
                [LocalPackage]
locals
    forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
        Text
"local packages"
        BaseConfigOpts
bco
        [DumpPackage]
dumpPackages
        String
"."
        (BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco)

-- | Generate Haddock index and contents for local packages and their dependencies.

generateDepsHaddockIndex
    :: (HasProcessContext env, HasLogFunc env, HasCompiler 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.
(HasProcessContext env, HasLogFunc env, HasCompiler 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 = (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
`lookupDumpPackage` [Map GhcPkgId DumpPackage]
allDumpPkgs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
        Text
"local packages and dependencies"
        BaseConfigOpts
bco
        [DumpPackage]
deps
        String
".."
        Path Abs Dir
depDocDir
  where
    getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
    getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{Bool
[Text]
Maybe (Map PackageName VersionRange)
Either License License
Set Text
Set PackageName
Set ExeName
Map Text TestSuiteInterface
Map FlagName Bool
Map PackageName DepValue
Version
PackageName
CabalSpecVersion
BuildType
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: CabalSpecVersion
packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageBuildType :: BuildType
packageHasExposedModules :: Bool
packageOpts :: GetPackageOpts
packageExes :: Set Text
packageBenchmarks :: Set Text
packageTests :: Map Text TestSuiteInterface
packageInternalLibraries :: Set Text
packageLibraries :: PackageLibraries
packageDefaultFlags :: Map FlagName Bool
packageFlags :: Map FlagName Bool
packageCabalConfigOpts :: [Text]
packageGhcOptions :: [Text]
packageAllDeps :: Set PackageName
packageUnknownTools :: Set ExeName
packageDeps :: Map PackageName DepValue
packageFiles :: GetPackageFiles
packageLicense :: Either License License
packageVersion :: Version
packageName :: PackageName
packageCabalSpec :: Package -> CabalSpecVersion
packageSetupDeps :: Package -> Maybe (Map PackageName VersionRange)
packageBuildType :: Package -> BuildType
packageHasExposedModules :: Package -> Bool
packageOpts :: Package -> GetPackageOpts
packageExes :: Package -> Set Text
packageBenchmarks :: Package -> Set Text
packageTests :: Package -> Map Text TestSuiteInterface
packageInternalLibraries :: Package -> Set Text
packageLibraries :: Package -> PackageLibraries
packageDefaultFlags :: Package -> Map FlagName Bool
packageFlags :: Package -> Map FlagName Bool
packageCabalConfigOpts :: Package -> [Text]
packageGhcOptions :: Package -> [Text]
packageAllDeps :: Package -> Set PackageName
packageUnknownTools :: Package -> Set ExeName
packageDeps :: Package -> Map PackageName DepValue
packageFiles :: Package -> GetPackageFiles
packageLicense :: Package -> Either License License
packageVersion :: Package -> Version
packageName :: Package -> PackageName
..}} =
        let pkgId :: PackageIdentifier
pkgId = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
packageName Version
packageVersion
            mdpPkg :: Maybe DumpPackage
mdpPkg = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId) Map GhcPkgId DumpPackage
localDumpPkgs
        in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DumpPackage -> GhcPkgId
dpGhcPkgId Maybe DumpPackage
mdpPkg
    findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
    findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends = (HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
`go` forall a. HashSet a
HS.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. HashSet a -> [a]
HS.toList HashSet GhcPkgId
todo of
                [] -> 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 -> forall a. HashSet a
HS.empty
                                Just DumpPackage
pkgDP -> forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
pkgDP)
                        deps' :: HashSet GhcPkgId
deps' = HashSet GhcPkgId
deps forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet GhcPkgId
checked
                        todo' :: HashSet GhcPkgId
todo' = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.delete GhcPkgId
ghcPkgId (HashSet GhcPkgId
deps' forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.union` HashSet GhcPkgId
todo)
                        checked' :: HashSet GhcPkgId
checked' = 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
    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)
    => BaseConfigOpts
    -> Map GhcPkgId DumpPackage  -- ^ Global package dump

    -> Map GhcPkgId DumpPackage  -- ^ Snapshot package dump

    -> RIO env ()
generateSnapHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs =
    forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
        Text
"snapshot packages"
        BaseConfigOpts
bco
        (forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
snapshotDumpPkgs forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
globalDumpPkgs)
        String
"."
        (BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco)

-- | Generate Haddock index and contents for specified packages.

generateHaddockIndex
    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)
    => Text
    -> BaseConfigOpts
    -> [DumpPackage]
    -> FilePath
    -> Path Abs Dir
    -> RIO env ()
generateHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex Text
descr BaseConfigOpts
bco [DumpPackage]
dumpPackages String
docRelFP Path Abs Dir
destDir = do
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
    [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts <- (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM DumpPackage
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt) [DumpPackage]
dumpPackages
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts) 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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 ->
                        forall (t :: * -> *). Foldable t => t Bool -> Bool
or [UTCTime
mt forall a. Ord a => a -> a -> Bool
> UTCTime
indexModTime | ([String]
_,UTCTime
mt,Path Abs File
_,Path Abs File
_) <- [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts]
        if Bool
needUpdate
            then do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"Updating Haddock index for " forall a. Semigroup a => a -> a -> a
<>
                  forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
" in\n" forall a. Semigroup a => a -> a -> a
<>
                  forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
destIndexFile)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts)
                String
haddockExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerPaths -> Path Abs File
cpHaddock)
                forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir) forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull
                    String
haddockExeName
                    (forall a b. (a -> b) -> [a] -> [b]
map ((String
"--optghc=-package-db=" forall a. [a] -> [a] -> [a]
++ ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
                        [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco, BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco] forall a. [a] -> [a] -> [a]
++
                     HaddockOpts -> [String]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco)) forall a. [a] -> [a] -> [a]
++
                     [String
"--gen-contents", String
"--gen-index"] forall a. [a] -> [a] -> [a]
++
                     [String
x | ([String]
xs,UTCTime
_,Path Abs File
_,Path Abs File
_) <- [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts, String
x <- [String]
xs])
            else
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
                Utf8Builder
"Haddock index for " forall a. Semigroup a => a -> a -> a
<>
                forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr forall a. Semigroup a => a -> a -> a
<>
                Utf8Builder
" already up to date at:\n" forall a. Semigroup a => a -> a -> a
<>
                forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
destIndexFile)
  where
    toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
    toInterfaceOpt :: DumpPackage
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt DumpPackage {Bool
[String]
[Text]
[GhcPkgId]
Maybe String
Maybe PackageIdentifier
Maybe License
Set ModuleName
PackageIdentifier
GhcPkgId
dpIsExposed :: DumpPackage -> Bool
dpHaddockHtml :: DumpPackage -> Maybe String
dpHaddockInterfaces :: DumpPackage -> [String]
dpExposedModules :: DumpPackage -> Set ModuleName
dpHasExposedModules :: DumpPackage -> Bool
dpLibraries :: DumpPackage -> [Text]
dpLibDirs :: DumpPackage -> [String]
dpLicense :: DumpPackage -> Maybe License
dpParentLibIdent :: DumpPackage -> Maybe PackageIdentifier
dpIsExposed :: Bool
dpHaddockHtml :: Maybe String
dpHaddockInterfaces :: [String]
dpDepends :: [GhcPkgId]
dpExposedModules :: Set ModuleName
dpHasExposedModules :: Bool
dpLibraries :: [Text]
dpLibDirs :: [String]
dpLicense :: Maybe License
dpParentLibIdent :: Maybe PackageIdentifier
dpPackageIdent :: PackageIdentifier
dpGhcPkgId :: GhcPkgId
dpDepends :: DumpPackage -> [GhcPkgId]
dpGhcPkgId :: DumpPackage -> GhcPkgId
dpPackageIdent :: DumpPackage -> PackageIdentifier
..} =
        case [String]
dpHaddockInterfaces of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            String
srcInterfaceFP:[String]
_ -> do
                Path Abs File
srcInterfaceAbsFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile String
srcInterfaceFP
                let (PackageIdentifier PackageName
name Version
_) = PackageIdentifier
dpPackageIdent
                    destInterfaceRelFP :: String
destInterfaceRelFP =
                        String
docRelFP String -> String -> String
FP.</>
                        PackageIdentifier -> String
packageIdentifierString PackageIdentifier
dpPackageIdent String -> String -> String
FP.</>
                        (PackageName -> String
packageNameString PackageName
name String -> String -> String
FP.<.> String
"haddock")
                    docPathRelFP :: Maybe String
docPathRelFP =
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
docRelFP String -> String -> String
FP.</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FP.takeFileName) Maybe String
dpHaddockHtml
                    interfaces :: String
interfaces = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$
                        forall a. Maybe a -> [a]
maybeToList Maybe String
docPathRelFP forall a. [a] -> [a] -> [a]
++ [String
srcInterfaceFP]

                Path Abs File
destInterfaceAbsFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile (forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir String -> String -> String
FP.</> String
destInterfaceRelFP)
                Either () UTCTime
esrcInterfaceModTime <- forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceAbsFile
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                    case Either () UTCTime
esrcInterfaceModTime of
                        Left ()
_ -> forall a. Maybe a
Nothing
                        Right UTCTime
srcInterfaceModTime ->
                            forall a. a -> Maybe a
Just
                                ( [ String
"-i", String
interfaces ]
                                , UTCTime
srcInterfaceModTime
                                , Path Abs File
srcInterfaceAbsFile
                                , Path Abs File
destInterfaceAbsFile )
    copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
    copyPkgDocs :: forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs (a
_,UTCTime
srcInterfaceModTime,Path Abs File
srcInterfaceAbsFile,Path Abs File
destInterfaceAbsFile) = 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 <- forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
destInterfaceAbsFile
        case Either () UTCTime
edestInterfaceModTime of
            Left ()
_ -> IO ()
doCopy
            Right UTCTime
destInterfaceModTime
                | UTCTime
destInterfaceModTime forall a. Ord a => a -> a -> Bool
< UTCTime
srcInterfaceModTime -> IO ()
doCopy
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        doCopy :: IO ()
doCopy = do
            forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir)
            forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destHtmlAbsDir
            forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
                (forall (m :: * -> *) b0 b1.
(MonadIO m, MonadCatch m) =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur' (forall b t. Path b t -> Path b Dir
parent Path Abs File
srcInterfaceAbsFile) Path Abs Dir
destHtmlAbsDir)
                (forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir))
        destHtmlAbsDir :: Path Abs Dir
destHtmlAbsDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
destInterfaceAbsFile

-- | 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 =
    forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml

-- | Path of local packages documentation directory.

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

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

localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco 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 -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
bco forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix