module Stack.Build.Haddock
( generateLocalHaddockIndex
, generateDepsHaddockIndex
, generateSnapHaddockIndex
, openHaddocksInBrowser
, shouldHaddockPackage
, shouldHaddockDeps
) where
import Control.Exception (tryJust, onException)
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Resource
import qualified Data.Foldable as F
import Data.Function
import qualified Data.HashSet as HS
import Data.List
import Data.List.Extra (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (mapMaybeM)
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (UTCTime)
import Path
import Path.Extra
import Path.IO
import Prelude
import Stack.PackageDump
import Stack.PrettyPrint
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.StackT (StackM)
import qualified System.FilePath as FP
import System.IO.Error (isDoesNotExistError)
import System.Process.Read
import Web.Browser (openBrowser)
openHaddocksInBrowser
:: StackM env m
=> BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> m ()
openHaddocksInBrowser bco pkgLocations buildTargets = do
let cliTargets = (boptsCLITargets . bcoBuildOptsCLI) bco
getDocIndex = do
let localDocs = haddockIndexFile (localDepsDocDir bco)
localExists <- doesFileExist localDocs
if localExists
then return localDocs
else do
let snapDocs = haddockIndexFile (snapDocDir bco)
snapExists <- doesFileExist snapDocs
if snapExists
then return snapDocs
else fail "No local or snapshot doc index found to open."
docFile <-
case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of
([_], [Just (pkgId, iloc)]) -> do
pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId
let docLocation =
case iloc of
Snap -> snapDocDir bco
Local -> localDocDir bco
let docFile = haddockIndexFile (docLocation </> pkgRelDir)
exists <- doesFileExist docFile
if exists
then return docFile
else do
$logWarn $
"Expected to find documentation at " <>
T.pack (toFilePath docFile) <>
", but that file is missing. Opening doc index instead."
getDocIndex
_ -> getDocIndex
$prettyInfo $ "Opening" <+> display docFile <+> "in the browser."
_ <- liftIO $ openBrowser (toFilePath docFile)
return ()
shouldHaddockPackage :: BuildOpts
-> Set PackageName
-> PackageName
-> Bool
shouldHaddockPackage bopts wanted name =
if Set.member name wanted
then boptsHaddock bopts
else shouldHaddockDeps bopts
shouldHaddockDeps :: BuildOpts -> Bool
shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts)
generateLocalHaddockIndex
:: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () () ())
-> [LocalPackage]
-> m ()
generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do
let dumpPackages =
mapMaybe
(\LocalPackage{lpPackage = Package{..}} ->
F.find
(\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion)
localDumpPkgs)
locals
generateHaddockIndex
"local packages"
envOverride
wc
(boptsHaddockOpts (bcoBuildOpts bco))
dumpPackages
"."
(localDocDir bco)
generateDepsHaddockIndex
:: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () () ())
-> Map GhcPkgId (DumpPackage () () ())
-> Map GhcPkgId (DumpPackage () () ())
-> [LocalPackage]
-> m ()
generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do
let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals
depDocDir = localDepsDocDir bco
generateHaddockIndex
"local packages and dependencies"
envOverride
wc
(boptsHaddockOpts (bcoBuildOpts bco))
deps
".."
depDocDir
where
getGhcPkgId :: LocalPackage -> Maybe GhcPkgId
getGhcPkgId LocalPackage{lpPackage = Package{..}} =
let pkgId = PackageIdentifier packageName packageVersion
mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs
in fmap dpGhcPkgId mdpPkg
findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId]
findTransitiveDepends = (`go` HS.empty) . HS.fromList
where
go todo checked =
case HS.toList todo of
[] -> HS.toList checked
(ghcPkgId:_) ->
let deps =
case lookupDumpPackage ghcPkgId allDumpPkgs of
Nothing -> HS.empty
Just pkgDP -> HS.fromList (dpDepends pkgDP)
deps' = deps `HS.difference` checked
todo' = HS.delete ghcPkgId (deps' `HS.union` todo)
checked' = HS.insert ghcPkgId checked
in go todo' checked'
allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs]
generateSnapHaddockIndex
:: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> WhichCompiler
-> BaseConfigOpts
-> Map GhcPkgId (DumpPackage () () ())
-> Map GhcPkgId (DumpPackage () () ())
-> m ()
generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs =
generateHaddockIndex
"snapshot packages"
envOverride
wc
(boptsHaddockOpts (bcoBuildOpts bco))
(Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs)
"."
(snapDocDir bco)
generateHaddockIndex
:: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m)
=> Text
-> EnvOverride
-> WhichCompiler
-> HaddockOpts
-> [DumpPackage () () ()]
-> FilePath
-> Path Abs Dir
-> m ()
generateHaddockIndex descr envOverride wc hdopts dumpPackages docRelFP destDir = do
ensureDir destDir
interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages
unless (null interfaceOpts) $ do
let destIndexFile = haddockIndexFile destDir
eindexModTime <- liftIO (tryGetModificationTime destIndexFile)
let needUpdate =
case eindexModTime of
Left _ -> True
Right indexModTime ->
or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts]
if needUpdate
then do
$logInfo
(T.concat ["Updating Haddock index for ", descr, " in\n",
T.pack (toFilePath destIndexFile)])
liftIO (mapM_ copyPkgDocs interfaceOpts)
readProcessNull
(Just destDir)
envOverride
(haddockExeName wc)
(hoAdditionalArgs hdopts ++
["--gen-contents", "--gen-index"] ++
[x | (xs,_,_,_) <- interfaceOpts, x <- xs])
else
$logInfo
(T.concat ["Haddock index for ", descr, " already up to date at:\n",
T.pack (toFilePath destIndexFile)])
where
toInterfaceOpt :: DumpPackage a b c -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File))
toInterfaceOpt DumpPackage {..} =
case dpHaddockInterfaces of
[] -> return Nothing
srcInterfaceFP:_ -> do
srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP
let (PackageIdentifier name _) = dpPackageIdent
destInterfaceRelFP =
docRelFP FP.</>
packageIdentifierString dpPackageIdent FP.</>
(packageNameString name FP.<.> "haddock")
destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP.</> destInterfaceRelFP)
esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile
return $
case esrcInterfaceModTime of
Left _ -> Nothing
Right srcInterfaceModTime ->
Just
( [ "-i"
, concat
[ docRelFP FP.</> packageIdentifierString dpPackageIdent
, ","
, destInterfaceRelFP ]]
, srcInterfaceModTime
, srcInterfaceAbsFile
, destInterfaceAbsFile )
tryGetModificationTime :: Path Abs File -> IO (Either () UTCTime)
tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime
copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do
edestInterfaceModTime <- tryGetModificationTime destInterfaceAbsFile
case edestInterfaceModTime of
Left _ -> doCopy
Right destInterfaceModTime
| destInterfaceModTime < srcInterfaceModTime -> doCopy
| otherwise -> return ()
where
doCopy = do
ignoringAbsence (removeDirRecur destHtmlAbsDir)
ensureDir destHtmlAbsDir
onException
(copyDirRecur' (parent srcInterfaceAbsFile) destHtmlAbsDir)
(ignoringAbsence (removeDirRecur destHtmlAbsDir))
destHtmlAbsDir = parent destInterfaceAbsFile
lookupDumpPackage :: GhcPkgId
-> [Map GhcPkgId (DumpPackage () () ())]
-> Maybe (DumpPackage () () ())
lookupDumpPackage ghcPkgId dumpPkgs =
listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile destDir = destDir </> $(mkRelFile "index.html")
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir bco = bcoLocalInstallRoot bco </> docDirSuffix
localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
localDepsDocDir bco = localDocDir bco </> $(mkRelDir "all")
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix