{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Build.Haddock
( copyDepHaddocks
, generateLocalHaddockIndex
, generateDepsHaddockIndex
, generateSnapHaddockIndex
, shouldHaddockPackage
, shouldHaddockDeps
) where
import Control.Exception (tryJust)
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 Data.Text (Text)
import qualified Data.Text as T
import Path
import Path.IO
import Prelude
import Safe (maximumMay)
import Stack.Types.Build
import Stack.GhcPkg
import Stack.Package
import Stack.Types
import System.Directory (getModificationTime)
import qualified System.FilePath as FP
import System.IO.Error (isDoesNotExistError)
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
-> WhichCompiler
-> BaseConfigOpts
-> [Path Abs Dir]
-> PackageIdentifier
-> Set (Path Abs Dir)
-> m ()
copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do
mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId
case mpkgHtmlDir of
Nothing -> return ()
Just (_pkgId, pkgHtmlDir) -> do
depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs $ packageIdentifierString pkgId
forM_ depGhcIds $ copyDepWhenNeeded pkgHtmlDir
where
copyDepWhenNeeded pkgHtmlDir depGhcId = do
mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ ghcPkgIdString depGhcId
case mDepOrigDir of
Nothing -> return ()
Just (depId, depOrigDir) -> do
let extraDestDirs' =
if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir ||
bcoLocalInstallRoot bco `isParentOf` pkgHtmlDir
then Set.insert (parent pkgHtmlDir) extraDestDirs
else extraDestDirs
copyWhenNeeded 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 wc bco 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
removeTreeIfExists depCopyDir
createTree depCopyDir
copyDirectoryRecursive depOrigDir depCopyDir
generateLocalHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m ()
generateLocalHaddockIndex envOverride wc bco locals = do
let packageIDs =
map
(\LocalPackage{lpPackage = Package{..}} ->
PackageIdentifier packageName packageVersion)
locals
generateHaddockIndex
"local packages"
envOverride
wc
packageIDs
"."
(localDocDir bco)
generateDepsHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m ()
generateDepsHaddockIndex envOverride wc bco locals = do
depSets <-
mapM
(\LocalPackage{lpPackage = Package{..}} ->
findTransitiveGhcPkgDepends
envOverride
wc
[bcoSnapDB bco, bcoLocalDB bco]
(PackageIdentifier packageName packageVersion))
locals
generateHaddockIndex
"local packages and dependencies"
envOverride
wc
(Set.toList (Set.unions depSets))
".."
(localDocDir bco </> $(mkRelDir "all"))
generateSnapHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> EnvOverride -> WhichCompiler -> BaseConfigOpts -> Path Abs Dir -> m ()
generateSnapHaddockIndex envOverride wc bco globalDB = do
pkgIds <- listGhcPkgDbs envOverride wc [globalDB, bcoSnapDB bco]
generateHaddockIndex
"snapshot packages"
envOverride
wc
pkgIds
"."
(snapDocDir bco)
generateHaddockIndex
:: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
=> Text
-> EnvOverride
-> WhichCompiler
-> [PackageIdentifier]
-> FilePath
-> Path Abs Dir
-> m ()
generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do
createTree destDir
interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs)
case maximumMay (map snd interfaceOpts) of
Nothing -> return ()
Just maxInterfaceModTime -> do
eindexModTime <-
liftIO $
tryJust (guard . isDoesNotExistError) $
getModificationTime (toFilePath (haddockIndexFile destDir))
let needUpdate =
case eindexModTime of
Left _ -> True
Right indexModTime ->
indexModTime < maxInterfaceModTime
when
needUpdate $
do $logInfo
("Updating Haddock index for " <> descr <> " in\n" <>
T.pack (toFilePath (haddockIndexFile destDir)))
readProcessNull
(Just destDir)
envOverride
(haddockExeName wc)
(["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts)
where
toInterfaceOpt pid@(PackageIdentifier name _) = do
let interfaceRelFile =
docRelDir FP.</> packageIdentifierString pid FP.</>
packageNameString name FP.<.>
"haddock"
interfaceAbsFile = toFilePath destDir FP.</> interfaceRelFile
einterfaceModTime <-
tryJust (guard . isDoesNotExistError) $
getModificationTime interfaceAbsFile
return $
case einterfaceModTime of
Left _ -> Nothing
Right interfaceModTime ->
Just
( [ "-i"
, concat
[ docRelDir FP.</> packageIdentifierString pid
, ","
, interfaceRelFile]]
, interfaceModTime)
haddockIndexFile :: Path Abs Dir -> Path Abs File
haddockIndexFile destDir = destDir </> $(mkRelFile "index.html")
localDocDir :: BaseConfigOpts -> Path Abs Dir
localDocDir bco = bcoLocalInstallRoot bco </> docDirSuffix
snapDocDir :: BaseConfigOpts -> Path Abs Dir
snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix