module Distribution.Simple.Haddock (
haddock, hscolour
) where
import Distribution.Package
( PackageIdentifier, Package(..) )
import Distribution.PackageDescription as PD
(PackageDescription(..), BuildInfo(..), hcOptions,
Library(..), hasLibs, withLib,
Executable(..), withExe)
import Distribution.Simple.Compiler
( Compiler(..), CompilerFlavor(..), compilerVersion
, extensionsToFlags )
import Distribution.Simple.Program
( ConfiguredProgram(..), requireProgram
, rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout
, hscolourProgram, haddockProgram, ghcProgram )
import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources,
PPSuffixHandler, runSimplePreProcessor)
import Distribution.Simple.Setup
import Distribution.Simple.Build (initialBuildSteps)
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,
PathTemplateVariable(..),
toPathTemplate, fromPathTemplate,
substPathTemplate,
initialPathTemplateEnv)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.BuildPaths ( haddockPref, haddockName,
hscolourPref, autogenModulesDir )
import qualified Distribution.Simple.PackageIndex as PackageIndex
( lookupPackageId )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(..) )
import Distribution.Simple.Utils
( die, warn, notice, intercalate, setupMessage
, createDirectoryIfMissingVerbose, withTempFile
, findFileWithExtension, findFile, dotToSep )
import Distribution.Text
( display, simpleParse )
import Distribution.Verbosity
import Language.Haskell.Extension
import System.Directory(removeFile, doesFileExist,
removeDirectoryRecursive, copyFile)
import Control.Monad ( when, unless )
import Data.Maybe ( isJust, fromJust, listToMaybe )
import Data.Char (isSpace)
import Data.List (nub)
import System.FilePath((</>), (<.>), splitFileName, splitExtension,
replaceExtension, normalise)
import System.IO (hClose, hPutStrLn)
import Distribution.Version
haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()
haddock pkg_descr _ _ haddockFlags
| not (hasLibs pkg_descr)
&& not (fromFlag $ haddockExecutables haddockFlags) =
warn (fromFlag $ haddockVerbosity haddockFlags) $
"No documentation was generated as this package does not contain "
++ "a library. Perhaps you want to use the haddock command with the "
++ "--executables."
haddock pkg_descr lbi suffixes flags = do
let distPref = fromFlag (haddockDistPref flags)
doExes = fromFlag (haddockExecutables flags)
hsColour = fromFlag (haddockHscolour flags)
when hsColour $ hscolour pkg_descr lbi suffixes defaultHscolourFlags {
hscolourCSS = haddockHscolourCss flags,
hscolourExecutables = haddockExecutables flags,
hscolourVerbosity = haddockVerbosity flags
}
(confHaddock, _) <- requireProgram verbosity haddockProgram
(orLaterVersion (Version [0,6] [])) (withPrograms lbi)
let tmpDir = buildDir lbi </> "tmp"
createDirectoryIfMissingVerbose verbosity True tmpDir
createDirectoryIfMissingVerbose verbosity True $
haddockPref distPref pkg_descr
preprocessSources pkg_descr lbi False verbosity suffixes
setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
let replaceLitExts = map ( (tmpDir </>) . (`replaceExtension` "hs") )
let showPkg = display (packageId pkg_descr)
let hoogle = fromFlag (haddockHoogle flags)
outputFlag | hoogle = "--hoogle"
| otherwise = "--html"
let Just version = programVersion confHaddock
let have_src_hyperlink_flags = version >= Version [0,8] []
isVersion2 = version >= Version [2,0] []
when (hoogle && isVersion2) $
die $ "haddock 2.x does not support the --hoogle flag."
let mockFlags
| isVersion2 = []
| otherwise = ["-D__HADDOCK__"]
let mockAll bi = mapM_ (mockPP mockFlags bi tmpDir)
let comp = compiler lbi
let cssFileFlag = case flagToMaybe $ haddockCss flags of
Nothing -> []
Just cssFile -> ["--css=" ++ cssFile]
let verboseFlags = if verbosity > deafening then ["--verbose"] else []
when (hsColour && not have_src_hyperlink_flags) $
die "haddock --hyperlink-source requires Haddock version 0.8 or later"
let linkToHscolour = if hsColour
then ["--source-module=src/%{MODULE/./-}.html"
,"--source-entity=src/%{MODULE/./-}.html#%{NAME}"]
else []
let htmlTemplate = fmap toPathTemplate $
flagToMaybe (haddockHtmlLocation flags)
packageFlags <- do
(packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate
maybe (return ()) (warn verbosity) warnings
return packageFlags
when isVersion2 $ do
strHadGhcVers <- rawSystemProgramStdout verbosity confHaddock ["--ghc-version"]
let mHadGhcVers :: Maybe Version
mHadGhcVers = simpleParse strHadGhcVers
when (mHadGhcVers == Nothing) $ die "Could not get GHC version from Haddock"
when (fromJust mHadGhcVers /= compilerVersion comp) $
die "Haddock's internal GHC version must match the configured GHC version"
ghcLibDir0 <- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]
let ghcLibDir = reverse $ dropWhile isSpace $ reverse ghcLibDir0
let packageName = if isVersion2
then ["--optghc=-package-name", "--optghc=" ++ showPkg]
else ["--package=" ++ showPkg]
let haddock2options bi preprocessDir = if isVersion2
then ("-B" ++ ghcLibDir) : map ("--optghc=" ++) (ghcSimpleOptions lbi bi preprocessDir)
else []
when isVersion2 $
initialBuildSteps distPref pkg_descr lbi verbosity suffixes
withLib pkg_descr () $ \lib -> do
let bi = libBuildInfo lib
modules = PD.exposedModules lib ++ otherModules bi
inFiles <- getLibSourceFiles lbi lib
unless isVersion2 $ mockAll bi inFiles
let template = showPkg ++ "-haddock-prolog.txt"
prolog | null (PD.description pkg_descr) = synopsis pkg_descr
| otherwise = PD.description pkg_descr
subtitle | null (synopsis pkg_descr) = ""
| otherwise = ": " ++ synopsis pkg_descr
titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"
| otherwise = ""
withTempFile distPref template $ \prologFileName prologFileHandle -> do
hPutStrLn prologFileHandle prolog
hClose prologFileHandle
let targets
| isVersion2 = modules
| otherwise = replaceLitExts inFiles
let haddockFile = haddockPref distPref pkg_descr
</> haddockName pkg_descr
let hideArgs | fromFlag (haddockInternal flags) = []
| otherwise = map ("--hide=" ++) (otherModules bi)
let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]
| otherwise = []
rawSystemProgram verbosity confHaddock
([ outputFlag
, "--odir=" ++ haddockPref distPref pkg_descr
, "--title=" ++ showPkg ++ subtitle ++ titleComment
, "--dump-interface=" ++ haddockFile
, "--prologue=" ++ prologFileName ]
++ packageName
++ cssFileFlag
++ linkToHscolour
++ packageFlags
++ programArgs confHaddock
++ verboseFlags
++ hideArgs
++ exportsFlags
++ haddock2options bi (buildDir lbi)
++ targets
)
notice verbosity $ "Documentation created: "
++ (haddockPref distPref pkg_descr </> "index.html")
withExe pkg_descr $ \exe -> when doExes $ do
let bi = buildInfo exe
exeTargetDir = haddockPref distPref pkg_descr </> exeName exe
createDirectoryIfMissingVerbose verbosity True exeTargetDir
inFiles@(srcMainPath:_) <- getExeSourceFiles lbi exe
mockAll bi inFiles
let template = showPkg ++ "-haddock-prolog.txt"
prolog | null (PD.description pkg_descr) = synopsis pkg_descr
| otherwise = PD.description pkg_descr
titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"
| otherwise = ""
withTempFile distPref template $ \prologFileName prologFileHandle -> do
hPutStrLn prologFileHandle prolog
hClose prologFileHandle
let targets
| isVersion2 = srcMainPath : otherModules bi
| otherwise = replaceLitExts inFiles
let preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]
| otherwise = []
rawSystemProgram verbosity confHaddock
([ outputFlag
, "--odir=" ++ exeTargetDir
, "--title=" ++ exeName exe ++ titleComment
, "--prologue=" ++ prologFileName ]
++ linkToHscolour
++ packageFlags
++ programArgs confHaddock
++ verboseFlags
++ exportsFlags
++ haddock2options bi preprocessDir
++ targets
)
notice verbosity $ "Documentation created: "
++ (exeTargetDir </> "index.html")
removeDirectoryRecursive tmpDir
where
verbosity = fromFlag (haddockVerbosity flags)
mockPP inputArgs bi pref file
= do let (filePref, fileName) = splitFileName file
let targetDir = pref </> filePref
let targetFile = targetDir </> fileName
let (targetFileNoext, targetFileExt) = splitExtension targetFile
let cppOutput = targetFileNoext <.> "hspp"
let hsFile = targetFileNoext <.> "hs"
createDirectoryIfMissingVerbose verbosity True targetDir
if (targetFileExt == ".lhs")
then runSimplePreProcessor ppUnlit file hsFile verbosity
else copyFile file hsFile
when (needsCpp bi) $ do
runSimplePreProcessor (ppCpp' inputArgs bi lbi)
hsFile cppOutput verbosity
removeFile hsFile
copyFile cppOutput hsFile
removeFile cppOutput
needsCpp :: BuildInfo -> Bool
needsCpp bi = CPP `elem` extensions bi
haddockPackageFlags :: LocalBuildInfo
-> Maybe PathTemplate
-> IO ([String], Maybe String)
haddockPackageFlags lbi htmlTemplate = do
interfaces <- sequence
[ case interfaceAndHtmlPath pkgid of
Nothing -> return (pkgid, Nothing)
Just (interface, html) -> do
exists <- doesFileExist interface
if exists
then return (pkgid, Just (interface, html))
else return (pkgid, Nothing)
| pkgid <- packageDeps lbi ]
let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]
warning = "The documentation for the following packages are not "
++ "installed. No links will be generated to these packages: "
++ intercalate ", " (map display missing)
flags = [ "--read-interface="
++ (if null html then "" else html ++ ",") ++ interface
| (_, Just (interface, html)) <- interfaces ]
return (flags, if null missing then Nothing else Just warning)
where
interfaceAndHtmlPath :: PackageIdentifier -> Maybe (FilePath, FilePath)
interfaceAndHtmlPath pkgId = do
pkg <- PackageIndex.lookupPackageId (installedPkgs lbi) pkgId
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
html <- case htmlTemplate of
Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)
return (interface, html)
where expandTemplateVars = fromPathTemplate . substPathTemplate env
env = (PrefixVar, prefix (installDirTemplates lbi))
: initialPathTemplateEnv pkgId (compilerId (compiler lbi))
ghcSimpleOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String]
ghcSimpleOptions lbi bi mockDir
= ["-hide-all-packages"]
++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ])
++ ["-i"]
++ hcOptions GHC bi
++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
++ ["-i" ++ autogenModulesDir lbi]
++ ["-i" ++ mockDir]
++ ["-I" ++ dir | dir <- PD.includeDirs bi]
++ ["-odir", mockDir]
++ ["-hidir", mockDir]
++ extensionsToFlags c (extensions bi)
where c = compiler lbi
hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()
hscolour pkg_descr lbi suffixes flags = do
let distPref = fromFlag $ hscolourDistPref flags
(hscolourProg, _) <- requireProgram verbosity hscolourProgram
(orLaterVersion (Version [1,8] [])) (withPrograms lbi)
createDirectoryIfMissingVerbose verbosity True $
hscolourPref distPref pkg_descr
preprocessSources pkg_descr lbi False verbosity suffixes
setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
let replaceDot = map (\c -> if c == '.' then '-' else c)
withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do
let bi = libBuildInfo lib
modules = PD.exposedModules lib ++ otherModules bi
outputDir = hscolourPref distPref pkg_descr </> "src"
createDirectoryIfMissingVerbose verbosity True outputDir
copyCSS hscolourProg outputDir
inFiles <- getLibSourceFiles lbi lib
flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
let outFile = outputDir </> replaceDot mo <.> "html"
in rawSystemProgram verbosity hscolourProg
["-css", "-anchor", "-o" ++ outFile, inFile]
withExe pkg_descr $ \exe -> when doExes $ do
let bi = buildInfo exe
modules = "Main" : otherModules bi
outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"
createDirectoryIfMissingVerbose verbosity True outputDir
copyCSS hscolourProg outputDir
inFiles <- getExeSourceFiles lbi exe
flip mapM_ (zip modules inFiles) $ \(mo, inFile) ->
let outFile = outputDir </> replaceDot mo <.> "html"
in rawSystemProgram verbosity hscolourProg
["-css", "-anchor", "-o" ++ outFile, inFile]
where copyCSS hscolourProg dir = case stylesheet of
Nothing | programVersion hscolourProg >= Just (Version [1,9] []) ->
rawSystemProgram verbosity hscolourProg
["-print-css", "-o" ++ dir </> "hscolour.css"]
| otherwise -> return ()
Just s -> copyFile s (dir </> "hscolour.css")
doExes = fromFlag (hscolourExecutables flags)
stylesheet = flagToMaybe (hscolourCSS flags)
verbosity = fromFlag (hscolourVerbosity flags)
getLibSourceFiles :: LocalBuildInfo -> Library -> IO [FilePath]
getLibSourceFiles lbi lib = sequence
[ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi)
(dotToSep module_) >>= maybe (notFound module_) (return . normalise)
| module_ <- modules ]
where
bi = libBuildInfo lib
modules = PD.exposedModules lib ++ otherModules bi
preprocessDir = buildDir lbi
notFound module_ = die $ "can't find source for module " ++ module_
getExeSourceFiles :: LocalBuildInfo -> Executable -> IO [FilePath]
getExeSourceFiles lbi exe = do
srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
moduleFiles <- sequence
[ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi)
(dotToSep module_) >>= maybe (notFound module_) (return . normalise)
| module_ <- modules ]
return (srcMainPath : moduleFiles)
where
bi = buildInfo exe
modules = otherModules bi
preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
notFound module_ = die $ "can't find source for module " ++ module_