{-# 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 :: 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 (BuildOptsCLI -> [Text])
-> (BaseConfigOpts -> BuildOptsCLI) -> BaseConfigOpts -> [Text]
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 <- 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 (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 <- 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 (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
snapDocs
                        else String -> RIO env (Path Abs File)
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, (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 <- (String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> RIO env (Path Rel Dir))
-> (PackageIdentifier -> String)
-> PackageIdentifier
-> RIO env (Path Rel Dir)
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 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 (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
docFile
                    else do
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                            Utf8Builder
"Expected to find documentation at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
docFile) Utf8Builder -> Utf8Builder -> Utf8Builder
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
    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."
    Bool
_ <- IO Bool -> RIO env Bool
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
$ String -> IO Bool
openBrowser (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
docFile)
    () -> RIO env ()
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 PackageName -> Set PackageName -> Bool
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 = Bool -> Maybe Bool -> Bool
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 :: 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{lpPackage :: LocalPackage -> Package
lpPackage = Package{Bool
[Text]
Maybe (Map PackageName VersionRange)
Either License License
BuildType
PackageName
VersionRange
Version
Set PackageName
Set Text
Set ExeName
Map FlagName Bool
Map PackageName DepValue
Map Text TestSuiteInterface
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: Package -> VersionRange
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 :: VersionRange
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
..}} ->
                    (DumpPackage -> Bool)
-> Map GhcPkgId DumpPackage -> Maybe DumpPackage
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find
                        (\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
packageName Version
packageVersion)
                        Map GhcPkgId DumpPackage
localDumpPkgs)
                [LocalPackage]
locals
    Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
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 :: 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]
-> String
-> Path Abs Dir
-> RIO env ()
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
BuildType
PackageName
VersionRange
Version
Set PackageName
Set Text
Set ExeName
Map FlagName Bool
Map PackageName DepValue
Map Text TestSuiteInterface
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: VersionRange
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 -> VersionRange
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 = (DumpPackage -> Bool)
-> Map GhcPkgId DumpPackage -> Maybe DumpPackage
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId) Map GhcPkgId DumpPackage
localDumpPkgs
        in (DumpPackage -> GhcPkgId) -> Maybe DumpPackage -> Maybe GhcPkgId
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` 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 -> [GhcPkgId]
dpDepends DumpPackage
pkgDP)
                        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, Hashable 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
    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)
    => BaseConfigOpts
    -> Map GhcPkgId DumpPackage  -- ^ Global package dump
    -> Map GhcPkgId DumpPackage  -- ^ Snapshot package dump
    -> RIO env ()
generateSnapHaddockIndex :: BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs =
    Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> 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)
        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 :: Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex Text
descr BaseConfigOpts
bco [DumpPackage]
dumpPackages String
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
    [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts <- (IO [([String], UTCTime, Path Abs File, Path Abs File)]
-> RIO env [([String], UTCTime, Path Abs File, Path Abs File)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [([String], UTCTime, Path Abs File, Path Abs File)]
 -> RIO env [([String], UTCTime, Path Abs File, Path Abs File)])
-> ([DumpPackage]
    -> IO [([String], UTCTime, Path Abs File, Path Abs File)])
-> [DumpPackage]
-> RIO env [([String], UTCTime, Path Abs File, Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([String], UTCTime, Path Abs File, Path Abs File)]
 -> [([String], UTCTime, Path Abs File, Path Abs File)])
-> IO [([String], UTCTime, Path Abs File, Path Abs File)]
-> IO [([String], UTCTime, Path Abs File, Path Abs File)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([String], UTCTime, Path Abs File, Path Abs File)]
-> [([String], UTCTime, Path Abs File, Path Abs File)]
forall a. Ord a => [a] -> [a]
nubOrd (IO [([String], UTCTime, Path Abs File, Path Abs File)]
 -> IO [([String], UTCTime, Path Abs File, Path Abs File)])
-> ([DumpPackage]
    -> IO [([String], UTCTime, Path Abs File, Path Abs File)])
-> [DumpPackage]
-> IO [([String], UTCTime, Path Abs File, Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DumpPackage
 -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)))
-> [DumpPackage]
-> IO [([String], UTCTime, Path Abs File, Path Abs File)]
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
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([([String], UTCTime, Path Abs File, Path Abs File)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([String], UTCTime, Path Abs File, Path Abs File)]
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 (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 | ([String]
_,UTCTime
mt,Path Abs File
_,Path Abs File
_) <- [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts]
        if Bool
needUpdate
            then do
                Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"Updating Haddock index for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
" in\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
destIndexFile)
                IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((([String], UTCTime, Path Abs File, Path Abs File) -> IO ())
-> [([String], UTCTime, Path Abs File, Path Abs File)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([String], UTCTime, Path Abs File, Path Abs File) -> IO ()
forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts)
                String
haddockExeName <- Getting String env String -> RIO env String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting String env String -> RIO env String)
-> Getting String env String -> RIO env String
forall a b. (a -> b) -> a -> b
$ Getting String env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLGetting String env CompilerPaths
-> ((String -> Const String String)
    -> CompilerPaths -> Const String CompilerPaths)
-> Getting String env String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CompilerPaths -> String) -> SimpleGetter CompilerPaths String
forall s a. (s -> a) -> SimpleGetter s a
to (Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> (CompilerPaths -> Path Abs File) -> CompilerPaths -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerPaths -> Path Abs File
cpHaddock)
                String -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull
                    String
haddockExeName
                    ((Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"--optghc=-package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) (String -> String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
                        [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco, BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                     HaddockOpts -> [String]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco)) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                     [String
"--gen-contents", String
"--gen-index"] [String] -> [String] -> [String]
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
              Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                Utf8Builder
"Haddock index for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                Utf8Builder
" already up to date at:\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
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 License
Maybe PackageIdentifier
PackageIdentifier
Set ModuleName
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
            [] -> Maybe ([String], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], UTCTime, Path Abs File, Path Abs File)
forall a. Maybe a
Nothing
            String
srcInterfaceFP:[String]
_ -> do
                Path Abs File
srcInterfaceAbsFile <- String -> IO (Path Abs File)
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 =
                        (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
docRelFP String -> String -> String
FP.</>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FP.takeFileName) Maybe String
dpHaddockHtml
                    interfaces :: String
interfaces = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                        Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
docPathRelFP [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
srcInterfaceFP]

                Path Abs File
destInterfaceAbsFile <- String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir String -> String -> String
FP.</> String
destInterfaceRelFP)
                Either () UTCTime
esrcInterfaceModTime <- Path Abs File -> IO (Either () UTCTime)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceAbsFile
                Maybe ([String], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], UTCTime, Path Abs File, Path Abs File)
 -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)))
-> Maybe ([String], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
forall a b. (a -> b) -> a -> b
$
                    case Either () UTCTime
esrcInterfaceModTime of
                        Left ()
_ -> Maybe ([String], UTCTime, Path Abs File, Path Abs File)
forall a. Maybe a
Nothing
                        Right UTCTime
srcInterfaceModTime ->
                            ([String], UTCTime, Path Abs File, Path Abs File)
-> Maybe ([String], UTCTime, Path Abs File, Path Abs File)
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 :: (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 <- Path Abs File -> IO (Either () UTCTime)
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
srcInterfaceModTime -> IO ()
doCopy
                | Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      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, MonadCatch 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 Path Abs File
srcInterfaceAbsFile) 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 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 =
    [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 local packages documentation directory.
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
bcoLocalInstallRoot 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
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 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 -> Path Abs Dir
bcoSnapInstallRoot 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
docDirSuffix