module Stack.Build.Haddock
( copyDepHaddocks
, generateHaddockIndex
, shouldHaddockPackage
, shouldHaddockDeps
) where
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Resource
import Control.Monad.Writer
import Data.Function
import Data.List
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Path
import Path.IO
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Types
import Stack.GhcPkg
import Stack.Package
import Stack.Types
import System.Directory hiding (findExecutable,
findFiles)
import qualified System.FilePath as FP
import System.Process.Read
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)
copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)
=> EnvOverride
-> [Path Abs Dir]
-> PackageIdentifier
-> Set (Path Abs Dir)
-> m ()
copyDepHaddocks envOverride pkgDbs pkgId extraDestDirs = do
mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride pkgDbs pkgId
case mpkgHtmlDir of
Nothing -> return ()
Just pkgHtmlDir -> do
depGhcIds <- findGhcPkgDepends envOverride pkgDbs pkgId
forM_ (map ghcPkgIdPackageIdentifier depGhcIds) $
copyDepWhenNeeded pkgHtmlDir
where
copyDepWhenNeeded pkgHtmlDir depId = do
mDepOrigDir <- findGhcPkgHaddockHtml envOverride pkgDbs depId
case mDepOrigDir of
Nothing -> return ()
Just depOrigDir ->
copyWhenNeeded (Set.insert (parent pkgHtmlDir) extraDestDirs)
depId depOrigDir
copyWhenNeeded destDirs depId depOrigDir = do
depRelDir <- parseRelDir (packageIdentifierString depId)
copied <- forM (Set.toList destDirs) $ \destDir -> do
let depCopyDir = destDir </> depRelDir
if depCopyDir == depOrigDir
then return False
else do
needCopy <- getNeedCopy depOrigDir depCopyDir
when needCopy $ doCopy depOrigDir depCopyDir
return needCopy
when (or copied) $
copyDepHaddocks envOverride pkgDbs depId destDirs
getNeedCopy depOrigDir depCopyDir = do
let depOrigIndex = haddockIndexFile depOrigDir
depCopyIndex = haddockIndexFile depCopyDir
depOrigExists <- fileExists depOrigIndex
depCopyExists <- fileExists depCopyIndex
case (depOrigExists, depCopyExists) of
(False, _) -> return False
(True, False) -> return True
(True, True) -> do
copyMod <- liftIO $ getModificationTime (toFilePath depCopyIndex)
origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex)
return (copyMod <= origMod)
doCopy depOrigDir depCopyDir = do
depCopyDirExists <- dirExists depCopyDir
liftIO $ do
when depCopyDirExists $
removeDirectoryRecursive (toFilePath depCopyDir)
createDirectoryIfMissing True (toFilePath depCopyDir)
copyDirectoryRecursive depOrigDir depCopyDir
generateHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride
-> BaseConfigOpts
-> [LocalPackage]
-> m ()
generateHaddockIndex envOverride bco locals = do
$logInfo ("Generating Haddock index in\n" <>
T.pack (toFilePath (haddockIndexFile docDir)))
interfaceArgs <- mapM (\LocalPackage {lpPackage = Package {..}} ->
toInterfaceOpt (PackageIdentifier packageName packageVersion))
locals
readProcessNull
(Just docDir)
envOverride
"haddock"
(["--gen-contents", "--gen-index"] ++ concat interfaceArgs)
where
docDir = bcoLocalInstallRoot bco </> docdirSuffix
toInterfaceOpt pid@(PackageIdentifier name _) = do
interfaceRelFile <- parseRelFile (packageIdentifierString pid FP.</>
packageNameString name FP.<.>
"haddock")
interfaceExists <- fileExists (docDir </> interfaceRelFile)
return $ if interfaceExists
then [ "-i"
, concat
[ packageIdentifierString pid
, ","
, toFilePath interfaceRelFile ] ]
else []
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile docDir = docDir </> $(mkRelFile "index.html")