{-# 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 :: forall env.
HasTerm env =>
BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
openHaddocksInBrowser BaseConfigOpts
bco Map PackageName (PackageIdentifier, InstallLocation)
pkgLocations Set PackageName
buildTargets = do
let cliTargets :: [Text]
cliTargets = (BuildOptsCLI -> [Text]
boptsCLITargets forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseConfigOpts -> BuildOptsCLI
bcoBuildOptsCLI) BaseConfigOpts
bco
getDocIndex :: RIO env (Path Abs File)
getDocIndex = do
let localDocs :: Path Abs File
localDocs = Path Abs Dir -> Path Abs File
haddockIndexFile (BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco)
Bool
localExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
localDocs
if Bool
localExists
then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
localDocs
else do
let snapDocs :: Path Abs File
snapDocs = Path Abs Dir -> Path Abs File
haddockIndexFile (BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco)
Bool
snapExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
snapDocs
if Bool
snapExists
then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
snapDocs
else forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No local or snapshot doc index found to open."
Path Abs File
docFile <-
case ([Text]
cliTargets, forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map PackageName (PackageIdentifier, InstallLocation)
pkgLocations) (forall a. Set a -> [a]
Set.toList Set PackageName
buildTargets)) of
([Text
_], [Just (PackageIdentifier
pkgId, InstallLocation
iloc)]) -> do
Path Rel Dir
pkgRelDir <- (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) PackageIdentifier
pkgId
let docLocation :: Path Abs Dir
docLocation =
case InstallLocation
iloc of
InstallLocation
Snap -> BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco
InstallLocation
Local -> BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco
let docFile :: Path Abs File
docFile = Path Abs Dir -> Path Abs File
haddockIndexFile (Path Abs Dir
docLocation forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
pkgRelDir)
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
docFile
if Bool
exists
then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
docFile
else do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Expected to find documentation at " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
docFile) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
", but that file is missing. Opening doc index instead."
RIO env (Path Abs File)
getDocIndex
([Text], [Maybe (PackageIdentifier, InstallLocation)])
_ -> RIO env (Path Abs File)
getDocIndex
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
docFile StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
Bool
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
openBrowser (forall b t. Path b t -> String
toFilePath Path Abs File
docFile)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
shouldHaddockPackage :: BuildOpts
-> Set PackageName
-> PackageName
-> Bool
shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool
shouldHaddockPackage BuildOpts
bopts Set PackageName
wanted PackageName
name =
if forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
name Set PackageName
wanted
then BuildOpts -> Bool
boptsHaddock BuildOpts
bopts
else BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps BuildOpts
bopts = forall a. a -> Maybe a -> a
fromMaybe (BuildOpts -> Bool
boptsHaddock BuildOpts
bopts) (BuildOpts -> Maybe Bool
boptsHaddockDeps BuildOpts
bopts)
generateLocalHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateLocalHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
locals = do
let dumpPackages :: [DumpPackage]
dumpPackages =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{Bool
[Text]
Maybe (Map PackageName VersionRange)
Either License License
Set Text
Set PackageName
Set ExeName
Map Text TestSuiteInterface
Map FlagName Bool
Map PackageName DepValue
Version
PackageName
CabalSpecVersion
BuildType
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: Package -> CabalSpecVersion
packageSetupDeps :: Package -> Maybe (Map PackageName VersionRange)
packageBuildType :: Package -> BuildType
packageHasExposedModules :: Package -> Bool
packageOpts :: Package -> GetPackageOpts
packageExes :: Package -> Set Text
packageBenchmarks :: Package -> Set Text
packageTests :: Package -> Map Text TestSuiteInterface
packageInternalLibraries :: Package -> Set Text
packageLibraries :: Package -> PackageLibraries
packageDefaultFlags :: Package -> Map FlagName Bool
packageFlags :: Package -> Map FlagName Bool
packageCabalConfigOpts :: Package -> [Text]
packageGhcOptions :: Package -> [Text]
packageAllDeps :: Package -> Set PackageName
packageUnknownTools :: Package -> Set ExeName
packageDeps :: Package -> Map PackageName DepValue
packageFiles :: Package -> GetPackageFiles
packageLicense :: Package -> Either License License
packageVersion :: Package -> Version
packageName :: Package -> PackageName
packageCabalSpec :: CabalSpecVersion
packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageBuildType :: BuildType
packageHasExposedModules :: Bool
packageOpts :: GetPackageOpts
packageExes :: Set Text
packageBenchmarks :: Set Text
packageTests :: Map Text TestSuiteInterface
packageInternalLibraries :: Set Text
packageLibraries :: PackageLibraries
packageDefaultFlags :: Map FlagName Bool
packageFlags :: Map FlagName Bool
packageCabalConfigOpts :: [Text]
packageGhcOptions :: [Text]
packageAllDeps :: Set PackageName
packageUnknownTools :: Set ExeName
packageDeps :: Map PackageName DepValue
packageFiles :: GetPackageFiles
packageLicense :: Either License License
packageVersion :: Version
packageName :: PackageName
..}} ->
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find
(\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp forall a. Eq a => a -> a -> Bool
== PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
packageName Version
packageVersion)
Map GhcPkgId DumpPackage
localDumpPkgs)
[LocalPackage]
locals
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
Text
"local packages"
BaseConfigOpts
bco
[DumpPackage]
dumpPackages
String
"."
(BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco)
generateDepsHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
locals = do
let deps :: [DumpPackage]
deps = (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
`lookupDumpPackage` [Map GhcPkgId DumpPackage]
allDumpPkgs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LocalPackage -> Maybe GhcPkgId
getGhcPkgId) [LocalPackage]
locals
depDocDir :: Path Abs Dir
depDocDir = BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
Text
"local packages and dependencies"
BaseConfigOpts
bco
[DumpPackage]
deps
String
".."
Path Abs Dir
depDocDir
where
getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage{lpPackage :: LocalPackage -> Package
lpPackage = Package{Bool
[Text]
Maybe (Map PackageName VersionRange)
Either License License
Set Text
Set PackageName
Set ExeName
Map Text TestSuiteInterface
Map FlagName Bool
Map PackageName DepValue
Version
PackageName
CabalSpecVersion
BuildType
GetPackageFiles
GetPackageOpts
PackageLibraries
packageCabalSpec :: CabalSpecVersion
packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageBuildType :: BuildType
packageHasExposedModules :: Bool
packageOpts :: GetPackageOpts
packageExes :: Set Text
packageBenchmarks :: Set Text
packageTests :: Map Text TestSuiteInterface
packageInternalLibraries :: Set Text
packageLibraries :: PackageLibraries
packageDefaultFlags :: Map FlagName Bool
packageFlags :: Map FlagName Bool
packageCabalConfigOpts :: [Text]
packageGhcOptions :: [Text]
packageAllDeps :: Set PackageName
packageUnknownTools :: Set ExeName
packageDeps :: Map PackageName DepValue
packageFiles :: GetPackageFiles
packageLicense :: Either License License
packageVersion :: Version
packageName :: PackageName
packageCabalSpec :: Package -> CabalSpecVersion
packageSetupDeps :: Package -> Maybe (Map PackageName VersionRange)
packageBuildType :: Package -> BuildType
packageHasExposedModules :: Package -> Bool
packageOpts :: Package -> GetPackageOpts
packageExes :: Package -> Set Text
packageBenchmarks :: Package -> Set Text
packageTests :: Package -> Map Text TestSuiteInterface
packageInternalLibraries :: Package -> Set Text
packageLibraries :: Package -> PackageLibraries
packageDefaultFlags :: Package -> Map FlagName Bool
packageFlags :: Package -> Map FlagName Bool
packageCabalConfigOpts :: Package -> [Text]
packageGhcOptions :: Package -> [Text]
packageAllDeps :: Package -> Set PackageName
packageUnknownTools :: Package -> Set ExeName
packageDeps :: Package -> Map PackageName DepValue
packageFiles :: Package -> GetPackageFiles
packageLicense :: Package -> Either License License
packageVersion :: Package -> Version
packageName :: Package -> PackageName
..}} =
let pkgId :: PackageIdentifier
pkgId = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
packageName Version
packageVersion
mdpPkg :: Maybe DumpPackage
mdpPkg = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (\DumpPackage
dp -> DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId) Map GhcPkgId DumpPackage
localDumpPkgs
in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DumpPackage -> GhcPkgId
dpGhcPkgId Maybe DumpPackage
mdpPkg
findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends = (HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
`go` forall a. HashSet a
HS.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList
where
go :: HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
go HashSet GhcPkgId
todo HashSet GhcPkgId
checked =
case forall a. HashSet a -> [a]
HS.toList HashSet GhcPkgId
todo of
[] -> forall a. HashSet a -> [a]
HS.toList HashSet GhcPkgId
checked
(GhcPkgId
ghcPkgId:[GhcPkgId]
_) ->
let deps :: HashSet GhcPkgId
deps =
case GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
lookupDumpPackage GhcPkgId
ghcPkgId [Map GhcPkgId DumpPackage]
allDumpPkgs of
Maybe DumpPackage
Nothing -> forall a. HashSet a
HS.empty
Just DumpPackage
pkgDP -> forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
pkgDP)
deps' :: HashSet GhcPkgId
deps' = HashSet GhcPkgId
deps forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet GhcPkgId
checked
todo' :: HashSet GhcPkgId
todo' = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.delete GhcPkgId
ghcPkgId (HashSet GhcPkgId
deps' forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.union` HashSet GhcPkgId
todo)
checked' :: HashSet GhcPkgId
checked' = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert GhcPkgId
ghcPkgId HashSet GhcPkgId
checked
in HashSet GhcPkgId -> HashSet GhcPkgId -> [GhcPkgId]
go HashSet GhcPkgId
todo' HashSet GhcPkgId
checked'
allDumpPkgs :: [Map GhcPkgId DumpPackage]
allDumpPkgs = [Map GhcPkgId DumpPackage
localDumpPkgs, Map GhcPkgId DumpPackage
snapshotDumpPkgs, Map GhcPkgId DumpPackage
globalDumpPkgs]
generateSnapHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
bco Map GhcPkgId DumpPackage
globalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs =
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
Text
"snapshot packages"
BaseConfigOpts
bco
(forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
snapshotDumpPkgs forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map GhcPkgId DumpPackage
globalDumpPkgs)
String
"."
(BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco)
generateHaddockIndex
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> Text
-> BaseConfigOpts
-> [DumpPackage]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex :: forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
Text
-> BaseConfigOpts
-> [DumpPackage]
-> String
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex Text
descr BaseConfigOpts
bco [DumpPackage]
dumpPackages String
docRelFP Path Abs Dir
destDir = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
[([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts <- (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM DumpPackage
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt) [DumpPackage]
dumpPackages
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts) forall a b. (a -> b) -> a -> b
$ do
let destIndexFile :: Path Abs File
destIndexFile = Path Abs Dir -> Path Abs File
haddockIndexFile Path Abs Dir
destDir
Either () UTCTime
eindexModTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
destIndexFile)
let needUpdate :: Bool
needUpdate =
case Either () UTCTime
eindexModTime of
Left ()
_ -> Bool
True
Right UTCTime
indexModTime ->
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [UTCTime
mt forall a. Ord a => a -> a -> Bool
> UTCTime
indexModTime | ([String]
_,UTCTime
mt,Path Abs File
_,Path Abs File
_) <- [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts]
if Bool
needUpdate
then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Updating Haddock index for " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" in\n" forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
destIndexFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts)
String
haddockExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerPaths -> Path Abs File
cpHaddock)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir) forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull
String
haddockExeName
(forall a b. (a -> b) -> [a] -> [b]
map ((String
"--optghc=-package-db=" forall a. [a] -> [a] -> [a]
++ ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
[BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco, BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco] forall a. [a] -> [a] -> [a]
++
HaddockOpts -> [String]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco)) forall a. [a] -> [a] -> [a]
++
[String
"--gen-contents", String
"--gen-index"] forall a. [a] -> [a] -> [a]
++
[String
x | ([String]
xs,UTCTime
_,Path Abs File
_,Path Abs File
_) <- [([String], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts, String
x <- [String]
xs])
else
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Haddock index for " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
Stack.Prelude.display Text
descr forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" already up to date at:\n" forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
destIndexFile)
where
toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt :: DumpPackage
-> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt DumpPackage {Bool
[String]
[Text]
[GhcPkgId]
Maybe String
Maybe PackageIdentifier
Maybe License
Set ModuleName
PackageIdentifier
GhcPkgId
dpIsExposed :: DumpPackage -> Bool
dpHaddockHtml :: DumpPackage -> Maybe String
dpHaddockInterfaces :: DumpPackage -> [String]
dpExposedModules :: DumpPackage -> Set ModuleName
dpHasExposedModules :: DumpPackage -> Bool
dpLibraries :: DumpPackage -> [Text]
dpLibDirs :: DumpPackage -> [String]
dpLicense :: DumpPackage -> Maybe License
dpParentLibIdent :: DumpPackage -> Maybe PackageIdentifier
dpIsExposed :: Bool
dpHaddockHtml :: Maybe String
dpHaddockInterfaces :: [String]
dpDepends :: [GhcPkgId]
dpExposedModules :: Set ModuleName
dpHasExposedModules :: Bool
dpLibraries :: [Text]
dpLibDirs :: [String]
dpLicense :: Maybe License
dpParentLibIdent :: Maybe PackageIdentifier
dpPackageIdent :: PackageIdentifier
dpGhcPkgId :: GhcPkgId
dpDepends :: DumpPackage -> [GhcPkgId]
dpGhcPkgId :: DumpPackage -> GhcPkgId
dpPackageIdent :: DumpPackage -> PackageIdentifier
..} =
case [String]
dpHaddockInterfaces of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
String
srcInterfaceFP:[String]
_ -> do
Path Abs File
srcInterfaceAbsFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile String
srcInterfaceFP
let (PackageIdentifier PackageName
name Version
_) = PackageIdentifier
dpPackageIdent
destInterfaceRelFP :: String
destInterfaceRelFP =
String
docRelFP String -> String -> String
FP.</>
PackageIdentifier -> String
packageIdentifierString PackageIdentifier
dpPackageIdent String -> String -> String
FP.</>
(PackageName -> String
packageNameString PackageName
name String -> String -> String
FP.<.> String
"haddock")
docPathRelFP :: Maybe String
docPathRelFP =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
docRelFP String -> String -> String
FP.</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FP.takeFileName) Maybe String
dpHaddockHtml
interfaces :: String
interfaces = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$
forall a. Maybe a -> [a]
maybeToList Maybe String
docPathRelFP forall a. [a] -> [a] -> [a]
++ [String
srcInterfaceFP]
Path Abs File
destInterfaceAbsFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile (forall b t. Path b t -> String
toFilePath Path Abs Dir
destDir String -> String -> String
FP.</> String
destInterfaceRelFP)
Either () UTCTime
esrcInterfaceModTime <- forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceAbsFile
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case Either () UTCTime
esrcInterfaceModTime of
Left ()
_ -> forall a. Maybe a
Nothing
Right UTCTime
srcInterfaceModTime ->
forall a. a -> Maybe a
Just
( [ String
"-i", String
interfaces ]
, UTCTime
srcInterfaceModTime
, Path Abs File
srcInterfaceAbsFile
, Path Abs File
destInterfaceAbsFile )
copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs :: forall a. (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs (a
_,UTCTime
srcInterfaceModTime,Path Abs File
srcInterfaceAbsFile,Path Abs File
destInterfaceAbsFile) = do
Either () UTCTime
edestInterfaceModTime <- forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
destInterfaceAbsFile
case Either () UTCTime
edestInterfaceModTime of
Left ()
_ -> IO ()
doCopy
Right UTCTime
destInterfaceModTime
| UTCTime
destInterfaceModTime forall a. Ord a => a -> a -> Bool
< UTCTime
srcInterfaceModTime -> IO ()
doCopy
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
doCopy :: IO ()
doCopy = do
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir)
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destHtmlAbsDir
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException
(forall (m :: * -> *) b0 b1.
(MonadIO m, MonadCatch m) =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur' (forall b t. Path b t -> Path b Dir
parent Path Abs File
srcInterfaceAbsFile) Path Abs Dir
destHtmlAbsDir)
(forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
destHtmlAbsDir))
destHtmlAbsDir :: Path Abs Dir
destHtmlAbsDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
destInterfaceAbsFile
lookupDumpPackage :: GhcPkgId
-> [Map GhcPkgId DumpPackage]
-> Maybe DumpPackage
lookupDumpPackage :: GhcPkgId -> [Map GhcPkgId DumpPackage] -> Maybe DumpPackage
lookupDumpPackage GhcPkgId
ghcPkgId [Map GhcPkgId DumpPackage]
dumpPkgs =
forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhcPkgId
ghcPkgId) [Map GhcPkgId DumpPackage]
dumpPkgs
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile Path Abs Dir
destDir = Path Abs Dir
destDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
bcoLocalInstallRoot BaseConfigOpts
bco forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
localDocDir BaseConfigOpts
bco forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirAll
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir BaseConfigOpts
bco = BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
bco forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix