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

-- | Generate haddocks

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

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.Process
import           Stack.Constants
import           Stack.PackageDump
import           Stack.Prelude
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.Package
import qualified System.FilePath as FP
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 (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 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
                        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
<>
                            FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
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 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)
    () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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 :: 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 =
            (LocalPackage -> Maybe DumpPackage)
-> [LocalPackage] -> [DumpPackage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                (\LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{PackageName
packageName :: PackageName
packageName :: Package -> PackageName
packageName, Version
packageVersion :: Version
packageVersion :: Package -> Version
packageVersion}} ->
                    (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]
-> FilePath
-> Path Abs Dir
-> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
        Text
"local packages"
        BaseConfigOpts
bco
        [DumpPackage]
dumpPackages
        FilePath
"."
        (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 = ((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.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
        Text
"local packages and dependencies"
        BaseConfigOpts
bco
        [DumpPackage]
deps
        FilePath
".."
        Path Abs Dir
depDocDir
  where
    getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
    getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{PackageName
packageName :: Package -> PackageName
packageName :: PackageName
packageName, Version
packageVersion :: Package -> Version
packageVersion :: Version
packageVersion}} =
        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 a b. (a -> b) -> Maybe a -> Maybe b
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 :: 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 =
    Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler 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
    :: (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]
-> 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
    [([FilePath], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts <- (IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
-> RIO env [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
 -> RIO env [([FilePath], UTCTime, Path Abs File, Path Abs File)])
-> ([DumpPackage]
    -> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)])
-> [DumpPackage]
-> RIO env [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([FilePath], UTCTime, Path Abs File, Path Abs File)]
 -> [([FilePath], UTCTime, Path Abs File, Path Abs File)])
-> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
-> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([FilePath], UTCTime, Path Abs File, Path Abs File)]
-> [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall a. Ord a => [a] -> [a]
nubOrd (IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
 -> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)])
-> ([DumpPackage]
    -> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)])
-> [DumpPackage]
-> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DumpPackage
 -> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)))
-> [DumpPackage]
-> IO [([FilePath], UTCTime, Path Abs File, Path Abs File)]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM DumpPackage
-> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt) [DumpPackage]
dumpPackages
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([([FilePath], UTCTime, Path Abs File, Path Abs File)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([FilePath], 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 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 | ([FilePath]
_,UTCTime
mt,Path Abs File
_,Path Abs File
_) <- [([FilePath], 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
<>
                  FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
destIndexFile)
                IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((([FilePath], UTCTime, Path Abs File, Path Abs File) -> IO ())
-> [([FilePath], UTCTime, Path Abs File, Path Abs File)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([FilePath], UTCTime, Path Abs File, Path Abs File) -> IO ()
forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs [([FilePath], UTCTime, Path Abs File, Path Abs File)]
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
compilerPathsLGetting 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
. CompilerPaths -> Path Abs File
cpHaddock)
                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 -> FilePath
forall a. [a] -> [a] -> [a]
++ ) (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 -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco, BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                     HaddockOpts -> [FilePath]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco)) [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,UTCTime
_,Path Abs File
_,Path Abs File
_) <- [([FilePath], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts, FilePath
x <- [FilePath]
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
<>
                FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
destIndexFile)
  where
    toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
    toInterfaceOpt :: DumpPackage
-> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt DumpPackage {[FilePath]
dpHaddockInterfaces :: [FilePath]
dpHaddockInterfaces :: DumpPackage -> [FilePath]
dpHaddockInterfaces, PackageIdentifier
dpPackageIdent :: DumpPackage -> PackageIdentifier
dpPackageIdent :: PackageIdentifier
dpPackageIdent, Maybe FilePath
dpHaddockHtml :: Maybe FilePath
dpHaddockHtml :: DumpPackage -> Maybe FilePath
dpHaddockHtml} =
        case [FilePath]
dpHaddockInterfaces of
            [] -> Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
forall a. Maybe a
Nothing
            FilePath
srcInterfaceFP:[FilePath]
_ -> do
                Path Abs File
srcInterfaceAbsFile <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
parseCollapsedAbsFile FilePath
srcInterfaceFP
                let (PackageIdentifier PackageName
name Version
_) = PackageIdentifier
dpPackageIdent
                    destInterfaceRelFP :: FilePath
destInterfaceRelFP =
                        FilePath
docRelFP FilePath -> FilePath -> FilePath
FP.</>
                        PackageIdentifier -> FilePath
packageIdentifierString PackageIdentifier
dpPackageIdent 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 FilePath -> FilePath -> FilePath
FP.</>) (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.takeFileName) Maybe FilePath
dpHaddockHtml
                    interfaces :: FilePath
interfaces = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                        Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
docPathRelFP [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
srcInterfaceFP]

                Path Abs File
destInterfaceAbsFile <- 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
esrcInterfaceModTime <- Path Abs File -> IO (Either () UTCTime)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceAbsFile
                Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
 -> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)))
-> Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
-> IO (Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File))
forall a b. (a -> b) -> a -> b
$
                    case Either () UTCTime
esrcInterfaceModTime of
                        Left ()
_ -> Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
forall a. Maybe a
Nothing
                        Right UTCTime
srcInterfaceModTime ->
                            ([FilePath], UTCTime, Path Abs File, Path Abs File)
-> Maybe ([FilePath], UTCTime, Path Abs File, Path Abs File)
forall a. a -> Maybe a
Just
                                ( [ FilePath
"-i", FilePath
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 <- 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 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, 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