{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
-> Set PackageName
-> 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 ()
shouldHaddockPackage :: BuildOpts
-> Set PackageName
-> 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
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)
generateLocalHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> [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)
generateDepsHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [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]
generateSnapHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> 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)
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
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
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
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
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
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
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