{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
-> 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 (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 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
snapDocs
if Bool
snapExists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
snapDocs
else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BuildException
HaddockIndexNotFound
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 => FilePath -> m (Path Rel Dir)
parseRelDir 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 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 => FilePath -> a
fromString (forall b t. Path b t -> FilePath
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
$ FilePath -> IO Bool
openBrowser (forall b t. Path b t -> FilePath
toFilePath Path Abs File
docFile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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{PackageName
packageName :: Package -> PackageName
packageName :: PackageName
packageName, Version
packageVersion :: Package -> Version
packageVersion :: Version
packageVersion}} ->
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]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex
Text
"local packages"
BaseConfigOpts
bco
[DumpPackage]
dumpPackages
FilePath
"."
(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]
-> 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 :: PackageName
packageName :: Package -> PackageName
packageName, Version
packageVersion :: Version
packageVersion :: Package -> Version
packageVersion}} =
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]
-> FilePath
-> 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)
FilePath
"."
(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]
-> FilePath
-> Path Abs Dir
-> RIO env ()
generateHaddockIndex Text
descr BaseConfigOpts
bco [DumpPackage]
dumpPackages FilePath
docRelFP Path Abs Dir
destDir = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
[([FilePath], 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 ([FilePath], 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 [([FilePath], 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 | ([FilePath]
_,UTCTime
mt,Path Abs File
_,Path Abs File
_) <- [([FilePath], 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 => FilePath -> a
fromString (forall b t. Path b t -> FilePath
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 [([FilePath], UTCTime, Path Abs File, Path Abs File)]
interfaceOpts)
FilePath
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 -> FilePath
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) =>
FilePath -> m a -> m a
withWorkingDir (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
destDir) forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull
FilePath
haddockExeName
(forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"--optghc=-package-db=" forall a. [a] -> [a] -> [a]
++ ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep)
[BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
bco, BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
bco] forall a. [a] -> [a] -> [a]
++
HaddockOpts -> [FilePath]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts (BaseConfigOpts -> BuildOpts
bcoBuildOpts BaseConfigOpts
bco)) forall a. [a] -> [a] -> [a]
++
[FilePath
"--gen-contents", FilePath
"--gen-index"] 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
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 => FilePath -> a
fromString (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 :: DumpPackage -> [FilePath]
dpHaddockInterfaces :: [FilePath]
dpHaddockInterfaces, PackageIdentifier
dpPackageIdent :: PackageIdentifier
dpPackageIdent :: DumpPackage -> PackageIdentifier
dpPackageIdent, Maybe FilePath
dpHaddockHtml :: DumpPackage -> Maybe FilePath
dpHaddockHtml :: Maybe FilePath
dpHaddockHtml} =
case [FilePath]
dpHaddockInterfaces of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
FilePath
srcInterfaceFP:[FilePath]
_ -> do
Path Abs File
srcInterfaceAbsFile <- 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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath
docRelFP FilePath -> FilePath -> FilePath
FP.</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.takeFileName) Maybe FilePath
dpHaddockHtml
interfaces :: FilePath
interfaces = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," forall a b. (a -> b) -> a -> b
$
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
docPathRelFP forall a. [a] -> [a] -> [a]
++ [FilePath
srcInterfaceFP]
Path Abs File
destInterfaceAbsFile <- forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs File)
parseCollapsedAbsFile (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
destDir FilePath -> FilePath -> FilePath
FP.</> FilePath
destInterfaceRelFP)
Either () UTCTime
esrcInterfaceModTime <- forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (Either () UTCTime)
tryGetModificationTime Path Abs File
srcInterfaceAbsFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
( [ 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
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
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