------------------------------------------------------------------------------- |-- Module : Distribution.Simple.Haddock-- Copyright : Isaac Jones 2003-2005---- Maintainer : cabal-devel@haskell.org-- Portability : portable---- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is-- a rather complicated module. It deals with two versions of haddock (0.x and-- 2.x). It has to do pre-processing for haddock 0.x which involves-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It-- uses information about installed packages (from @ghc-pkg@) to find the-- locations of documentation for dependent packages, so it can create links.---- The @hscolour@ support allows generating html versions of the original-- source, with coloured syntax highlighting.{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}moduleDistribution.Simple.Haddock(haddock,hscolour)where-- localimportDistribution.Package(PackageIdentifier,Package(..),packageName)importqualifiedDistribution.ModuleNameasModuleNameimportDistribution.PackageDescriptionasPD(PackageDescription(..),BuildInfo(..),allExtensions,Library(..),hasLibs,withLib,Executable(..),withExe)importDistribution.Simple.Compiler(Compiler(..),compilerVersion)importDistribution.Simple.GHC(ghcLibDir)importDistribution.Simple.Program(ConfiguredProgram(..),requireProgramVersion,rawSystemProgram,rawSystemProgramStdout,hscolourProgram,haddockProgram)importDistribution.Simple.PreProcess(ppCpp',ppUnlit,PPSuffixHandler,runSimplePreProcessor)importDistribution.Simple.Setup(defaultHscolourFlags,Flag(..),flagToMaybe,fromFlag,HaddockFlags(..),HscolourFlags(..))importDistribution.Simple.Build(initialBuildSteps)importDistribution.Simple.InstallDirs(InstallDirs(..),PathTemplate,PathTemplateVariable(..),toPathTemplate,fromPathTemplate,substPathTemplate,initialPathTemplateEnv)importDistribution.Simple.LocalBuildInfo(LocalBuildInfo(..),externalPackageDeps,ComponentLocalBuildInfo(..),withLibLBI,withExeLBI)importDistribution.Simple.BuildPaths(haddockName,hscolourPref,autogenModulesDir,)importDistribution.Simple.PackageIndex(dependencyClosure)importqualifiedDistribution.Simple.PackageIndexasPackageIndeximportqualifiedDistribution.InstalledPackageInfoasInstalledPackageInfo(InstalledPackageInfo_(..))importDistribution.InstalledPackageInfo(InstalledPackageInfo)importDistribution.Simple.Utils(die,warn,notice,intercalate,setupMessage,createDirectoryIfMissingVerbose,withTempFile,copyFileVerbose,withTempDirectory,findFileWithExtension,findFile)importDistribution.Simple.GHC(ghcOptions)importDistribution.Text(display,simpleParse)importDistribution.VerbosityimportLanguage.Haskell.Extension-- BaseimportSystem.Directory(removeFile,doesFileExist,createDirectoryIfMissing)importControl.Monad(when,guard)importControl.Exception(assert)importData.MonoidimportData.Maybe(fromMaybe,listToMaybe)importSystem.FilePath((</>),(<.>),splitFileName,splitExtension,normalise,splitPath,joinPath)importSystem.IO(hClose,hPutStrLn)importDistribution.Version-- Types -- | record that represents the arguments to the haddock executable, a product monoid.dataHaddockArgs=HaddockArgs{argInterfaceFile::FlagFilePath,-- ^ path of the interface file, relative to argOutputDir, required.argPackageName::FlagPackageIdentifier,-- ^ package name, required.argHideModules::(All,[ModuleName.ModuleName]),-- ^ (hide modules ?, modules to hide)argIgnoreExports::Any,-- ^ ingore export lists in modules?argLinkSource::Flag(Template,Template),-- ^ (template for modules, template for symbols)argCssFile::FlagFilePath,-- ^ optinal custom css file.argVerbose::Any,argOutput::Flag[Output],-- ^ Html or Hoogle doc or both? required.argInterfaces::[(FilePath,MaybeFilePath)],-- ^ [(interface file, path to the html docs for links)]argOutputDir::Directory,-- ^ where to generate the documentation.argTitle::FlagString,-- ^ page's title, required.argPrologue::FlagString,-- ^ prologue text, required.argGhcFlags::[String],-- ^ additional flags to pass to ghc for haddock-2argGhcLibDir::FlagFilePath,-- ^ to find the correct ghc, required by haddock-2.argTargets::[FilePath]-- ^ modules to process.}-- | the FilePath of a directory, it's a monoid under (</>)newtypeDirectory=Dir{unDir'::FilePath}deriving(Read,Show,Eq,Ord)unDir::Directory->FilePathunDir=joinPath.filter(\p->p/="./"&&p/=".").splitPath.unDir'typeTemplate=StringdataOutput=Html|Hoogle-- ---------------------------------------------------------------------------- Haddock supporthaddock::PackageDescription->LocalBuildInfo->[PPSuffixHandler]->HaddockFlags->IO()haddockpkg_descr__haddockFlags|not(hasLibspkg_descr)&&not(fromFlag$haddockExecutableshaddockFlags)=warn(fromFlag$haddockVerbosityhaddockFlags)$"No documentation was generated as this package does not contain "++"a library. Perhaps you want to use the --executables flag."haddockpkg_descrlbisuffixesflags=dosetupMessageverbosity"Running Haddock for"(packageIdpkg_descr)(confHaddock,version,_)<-requireProgramVersionverbosityhaddockProgram(orLaterVersion(Version[0,6][]))(withProgramslbi)-- various sanity checksletisVersion2=version>=Version[2,0][]when(flaghaddockHoogle&&version>Version[2][]&&version<Version[2,2][])$die"haddock 2.0 and 2.1 do not support the --hoogle flag."when(flaghaddockHscolour&&version<Version[0,8][])$die"haddock --hyperlink-source requires Haddock version 0.8 or later"whenisVersion2$dohaddockGhcVersionStr<-rawSystemProgramStdoutverbosityconfHaddock["--ghc-version"]casesimpleParsehaddockGhcVersionStrofNothing->die"Could not get GHC version from Haddock"JusthaddockGhcVersion|haddockGhcVersion==ghcVersion->return()|otherwise->die$"Haddock's internal GHC version must match the configured "++"GHC version.\n"++"The GHC version is "++displayghcVersion++" but "++"haddock is using GHC version "++displayhaddockGhcVersionwhereghcVersion=compilerVersion(compilerlbi)-- the tools match the requests, we can proceedinitialBuildSteps(flaghaddockDistPref)pkg_descrlbiverbositysuffixeswhen(flaghaddockHscolour)$hscolour'pkg_descrlbi$defaultHscolourFlags`mappend`haddockToHscolourflagsargs<-fmapmconcat.sequence$[getInterfacesverbositylbi(flagToMaybe(haddockHtmlLocationflags)),getGhcLibDirverbositylbiisVersion2]++mapreturn[fromFlagsflags,fromPackageDescriptionpkg_descr]withLibLBIpkg_descrlbi$\libclbi->withTempDirectoryverbosity(buildDirlbi)"tmp"$\tmp->doletbi=libBuildInfoliblibArgs<-fromLibrarytmplbilibclbilibArgs'<-prepareSourcesverbositytmplbiisVersion2bi(args`mappend`libArgs)runHaddockverbosityconfHaddocklibArgs'when(flaghaddockExecutables)$withExeLBIpkg_descrlbi$\execlbi->withTempDirectoryverbosity(buildDirlbi)"tmp"$\tmp->doletbi=buildInfoexeexeArgs<-fromExecutabletmplbiexeclbiexeArgs'<-prepareSourcesverbositytmplbiisVersion2bi(args`mappend`exeArgs)runHaddockverbosityconfHaddockexeArgs'whereverbosity=flaghaddockVerbosityflagf=fromFlag$fflags-- | performs cpp and unlit preprocessing where needed on the files in-- | argTargets, which must have an .hs or .lhs extension.prepareSources::Verbosity->FilePath->LocalBuildInfo->Bool-- haddock == 2.*->BuildInfo->HaddockArgs->IOHaddockArgsprepareSourcesverbositytmplbiisVersion2biargs@HaddockArgs{argTargets=files}=mapM(mockPPtmp)files>>=\targets->returnargs{argTargets=targets}wheremockPPpreffile=dolet(filePref,fileName)=splitFileNamefiletargetDir=pref</>filePreftargetFile=targetDir</>fileName(targetFileNoext,targetFileExt)=splitExtension$targetFilehsFile=targetFileNoext<.>"hs"assert(targetFileExt`elem`[".lhs",".hs"])$return()createDirectoryIfMissingTruetargetDirifneedsCppthendorunSimplePreProcessor(ppCpp'definesbilbi)filetargetFileverbosityelsecopyFileVerboseverbosityfiletargetFilewhen(targetFileExt==".lhs")$dorunSimplePreProcessorppUnlittargetFilehsFileverbosityremoveFiletargetFilereturnhsFileneedsCpp=CPP`elem`allExtensionsbidefines|isVersion2=[]|otherwise=["-D__HADDOCK__"]---------------------------------------------------------------------------------------------------- constributions to HaddockArgsfromFlags::HaddockFlags->HaddockArgsfromFlagsflags=mempty{argHideModules=(maybemempty(All.not)$flagToMaybe(haddockInternalflags),mempty),argLinkSource=iffromFlag(haddockHscolourflags)thenFlag("src/%{MODULE/./-}.html","src/%{MODULE/./-}.html#%{NAME}")elseNoFlag,argCssFile=haddockCssflags,argVerbose=maybemempty(Any.(>=deafening)).flagToMaybe$haddockVerbosityflags,argOutput=Flag$case[Html|FlagTrue<-[haddockHtmlflags]]++[Hoogle|FlagTrue<-[haddockHoogleflags]]of[]->[Html]os->os,argOutputDir=maybememptyDir.flagToMaybe$haddockDistPrefflags}fromPackageDescription::PackageDescription->HaddockArgsfromPackageDescriptionpkg_descr=mempty{argInterfaceFile=Flag$haddockNamepkg_descr,argPackageName=Flag$packageId$pkg_descr,argOutputDir=Dir$"doc"</>"html"</>display(packageNamepkg_descr),argPrologue=Flag$ifnulldescthensynopsispkg_descrelsedesc,argTitle=Flag$showPkg++subtitle}wheredesc=PD.descriptionpkg_descrshowPkg=display(packageIdpkg_descr)subtitle|null(synopsispkg_descr)=""|otherwise=": "++synopsispkg_descrfromLibrary::FilePath->LocalBuildInfo->Library->ComponentLocalBuildInfo->IOHaddockArgsfromLibrarytmplbilibclbi=doinFiles<-mapsnd`fmap`getLibSourceFileslbilibreturn$mempty{argHideModules=(mempty,otherModules$bi),argGhcFlags=ghcOptionslbibiclbi(buildDirlbi)-- Noooooooooo!!!!!111-- haddock stomps on our precious .hi-- and .o files. Workaround by telling-- haddock to write them elsewhere.++["-odir",tmp,"-hidir",tmp,"-stubdir",tmp],argTargets=inFiles}wherebi=libBuildInfolibfromExecutable::FilePath->LocalBuildInfo->Executable->ComponentLocalBuildInfo->IOHaddockArgsfromExecutabletmplbiexeclbi=doinFiles<-mapsnd`fmap`getExeSourceFileslbiexereturn$mempty{argGhcFlags=ghcOptionslbibiclbi(buildDirlbi)-- Noooooooooo!!!!!111-- haddock stomps on our precious .hi-- and .o files. Workaround by telling-- haddock to write them elsewhere.++["-odir",tmp,"-hidir",tmp,"-stubdir",tmp],argOutputDir=Dir(exeNameexe),argTitle=Flag(exeNameexe),argTargets=inFiles}wherebi=buildInfoexegetInterfaces::Verbosity->LocalBuildInfo->MaybeString-- ^ template for html location->IOHaddockArgsgetInterfacesverbositylbilocation=dolethtmlTemplate=fmaptoPathTemplate$location(packageFlags,warnings)<-haddockPackageFlagslbihtmlTemplatemaybe(return())(warnverbosity)warningsreturn$mempty{argInterfaces=packageFlags}getGhcLibDir::Verbosity->LocalBuildInfo->Bool-- ^ are we using haddock-2.x ?->IOHaddockArgsgetGhcLibDirverbositylbiisVersion2|isVersion2=dol<-ghcLibDirverbositylbireturn$mempty{argGhcLibDir=Flagl}|otherwise=returnmempty------------------------------------------------------------------------------------------------ | Call haddock with the specified arguments.runHaddock::Verbosity->ConfiguredProgram->HaddockArgs->IO()runHaddockverbosityconfHaddockargs=dolethaddockVersion=fromMaybe(error"unable to determine haddock version")(programVersionconfHaddock)renderArgsverbosityhaddockVersionargs$\(flags,result)->dorawSystemProgramverbosityconfHaddockflagsnoticeverbosity$"Documentation created: "++resultrenderArgs::Verbosity->Version->HaddockArgs->(([[Char]],FilePath)->IOa)->IOarenderArgsverbosityversionargsk=docreateDirectoryIfMissingVerboseverbosityTrueoutputDirwithTempFileoutputDir"haddock-prolog.txt"$\prologFileNameh->dodohPutStrLnh$fromFlag$argPrologueargshClosehletpflag=(:[]).("--prologue="++)$prologFileNamek$(pflag++renderPureArgsversionargs,result)whereisVersion2=version>=Version[2,0][]outputDir=(unDir$argOutputDirargs)result=intercalate", ".map(\o->outputDir</>caseoofHtml->"index.html"Hoogle->pkgstr<.>"txt")$argargOutputwherepkgstr|isVersion2=display$packageNamepkgid|otherwise=displaypkgidpkgid=argargPackageNameargf=fromFlag$fargsrenderPureArgs::Version->HaddockArgs->[[Char]]renderPureArgsversionargs=concat[(:[]).(\f->"--dump-interface="++unDir(argOutputDirargs)</>f).fromFlag.argInterfaceFile$args,(\pkgName->ifisVersion2then["--optghc=-package-name","--optghc="++pkgName]else["--package="++pkgName]).display.fromFlag.argPackageName$args,(\(Allb,xs)->bool(map(("--hide="++).display)xs)[]b).argHideModules$args,bool["--ignore-all-exports"][].getAny.argIgnoreExports$args,maybe[](\(m,e)->["--source-module="++m,"--source-entity="++e]).flagToMaybe.argLinkSource$args,maybe[]((:[]).("--css="++)).flagToMaybe.argCssFile$args,bool[][verbosityFlag].getAny.argVerbose$args,map(\o->caseoofHoogle->"--hoogle";Html->"--html").fromFlag.argOutput$args,renderInterfaces.argInterfaces$args,(:[]).("--odir="++).unDir.argOutputDir$args,(:[]).("--title="++).(bool(++" (internal documentation)")id(getAny$argIgnoreExportsargs)).fromFlag.argTitle$args,boolid(const[])isVersion2.map("--optghc="++).argGhcFlags$args,maybe[](\l->["-B"++l])$guardisVersion2>>flagToMaybe(argGhcLibDirargs),-- error if isVersion2 and Nothing?argTargets$args]whererenderInterfaces=map(\(i,mh)->"--read-interface="++maybe""(++",")mh++i)boolabc=ifcthenaelsebisVersion2=version>=Version[2,0][]isVersion2_5=version>=Version[2,5][]verbosityFlag|isVersion2_5="--verbosity=1"|otherwise="--verbose"-----------------------------------------------------------------------------------------------------------haddockPackageFlags::LocalBuildInfo->MaybePathTemplate->IO([(FilePath,MaybeFilePath)],MaybeString)haddockPackageFlagslbihtmlTemplate=doletallPkgs=installedPkgslbidirectDeps=mapfst(externalPackageDepslbi)transitiveDeps<-casedependencyClosureallPkgsdirectDepsofLeftx->returnxRight_->die"Can't find transitive deps for haddock"interfaces<-sequence[caseinterfaceAndHtmlPathipkgofNothing->return(Left(packageIdipkg))Just(interface,html)->doexists<-doesFileExistinterfaceifexiststhenreturn(Right(interface,html))elsereturn(Left(packageIdipkg))|ipkg<-PackageIndex.allPackagestransitiveDeps]letmissing=[pkgid|Leftpkgid<-interfaces]warning="The documentation for the following packages are not "++"installed. No links will be generated to these packages: "++intercalate", "(mapdisplaymissing)flags=[(interface,ifnullhtmlthenNothingelseJusthtml)|Right(interface,html)<-interfaces]return(flags,ifnullmissingthenNothingelseJustwarning)whereinterfaceAndHtmlPath::InstalledPackageInfo->Maybe(FilePath,FilePath)interfaceAndHtmlPathpkg=dointerface<-listToMaybe(InstalledPackageInfo.haddockInterfacespkg)html<-casehtmlTemplateofNothing->listToMaybe(InstalledPackageInfo.haddockHTMLspkg)JusthtmlPathTemplate->Just(expandTemplateVarshtmlPathTemplate)return(interface,html)whereexpandTemplateVars=fromPathTemplate.substPathTemplateenvenv=(PrefixVar,prefix(installDirTemplateslbi)):initialPathTemplateEnv(packageIdpkg)(compilerId(compilerlbi))-- ---------------------------------------------------------------------------- hscolour supporthscolour::PackageDescription->LocalBuildInfo->[PPSuffixHandler]->HscolourFlags->IO()hscolourpkg_descrlbisuffixesflags=do-- we preprocess even if hscolour won't be found on the machine-- will this upset someone?initialBuildStepsdistPrefpkg_descrlbiverbositysuffixeshscolour'pkg_descrlbiflagswhereverbosity=fromFlag(hscolourVerbosityflags)distPref=fromFlag$hscolourDistPrefflagshscolour'::PackageDescription->LocalBuildInfo->HscolourFlags->IO()hscolour'pkg_descrlbiflags=doletdistPref=fromFlag$hscolourDistPrefflags(hscolourProg,_,_)<-requireProgramVersionverbosityhscolourProgram(orLaterVersion(Version[1,8][]))(withProgramslbi)setupMessageverbosity"Running hscolour for"(packageIdpkg_descr)createDirectoryIfMissingVerboseverbosityTrue$hscolourPrefdistPrefpkg_descrwithLibpkg_descr$\lib->doletoutputDir=hscolourPrefdistPrefpkg_descr</>"src"runHsColourhscolourProgoutputDir=<<getLibSourceFileslbilibwhen(fromFlag(hscolourExecutablesflags))$withExepkg_descr$\exe->doletoutputDir=hscolourPrefdistPrefpkg_descr</>exeNameexe</>"src"runHsColourhscolourProgoutputDir=<<getExeSourceFileslbiexewherestylesheet=flagToMaybe(hscolourCSSflags)verbosity=fromFlag(hscolourVerbosityflags)runHsColourprogoutputDirmoduleFiles=docreateDirectoryIfMissingVerboseverbosityTrueoutputDircasestylesheetof-- copy the CSS file Nothing|programVersionprog>=Just(Version[1,9][])->rawSystemProgramverbosityprog["-print-css","-o"++outputDir</>"hscolour.css"]|otherwise->return()Justs->copyFileVerboseverbositys(outputDir</>"hscolour.css")flipmapM_moduleFiles$\(m,inFile)->rawSystemProgramverbosityprog["-css","-anchor","-o"++outFilem,inFile]whereoutFilem=outputDir</>intercalate"-"(ModuleName.componentsm)<.>"html"haddockToHscolour::HaddockFlags->HscolourFlagshaddockToHscolourflags=HscolourFlags{hscolourCSS=haddockHscolourCssflags,hscolourExecutables=haddockExecutablesflags,hscolourVerbosity=haddockVerbosityflags,hscolourDistPref=haddockDistPrefflags}------------------------------------------------------------------------------------------------ TODO these should be moved elsewhere.getLibSourceFiles::LocalBuildInfo->Library->IO[(ModuleName.ModuleName,FilePath)]getLibSourceFileslbilib=getSourceFilessearchpathsmoduleswherebi=libBuildInfolibmodules=PD.exposedModuleslib++otherModulesbisearchpaths=autogenModulesDirlbi:buildDirlbi:hsSourceDirsbigetExeSourceFiles::LocalBuildInfo->Executable->IO[(ModuleName.ModuleName,FilePath)]getExeSourceFileslbiexe=domoduleFiles<-getSourceFilessearchpathsmodulessrcMainPath<-findFile(hsSourceDirsbi)(modulePathexe)return((ModuleName.main,srcMainPath):moduleFiles)wherebi=buildInfoexemodules=otherModulesbisearchpaths=autogenModulesDirlbi:exeBuildDirlbiexe:hsSourceDirsbigetSourceFiles::[FilePath]->[ModuleName.ModuleName]->IO[(ModuleName.ModuleName,FilePath)]getSourceFilesdirsmodules=flipmapMmodules$\m->fmap((,)m)$findFileWithExtension["hs","lhs"]dirs(ModuleName.toFilePathm)>>=maybe(notFoundm)(return.normalise)wherenotFoundmodule_=die$"can't find source for module "++displaymodule_-- | The directory where we put build results for an executableexeBuildDir::LocalBuildInfo->Executable->FilePathexeBuildDirlbiexe=buildDirlbi</>exeNameexe</>exeNameexe++"-tmp"----------------------------------------------------------------------------------------------- boilerplate monoid instance.instanceMonoidHaddockArgswheremempty=HaddockArgs{argInterfaceFile=mempty,argPackageName=mempty,argHideModules=mempty,argIgnoreExports=mempty,argLinkSource=mempty,argCssFile=mempty,argVerbose=mempty,argOutput=mempty,argInterfaces=mempty,argOutputDir=mempty,argTitle=mempty,argPrologue=mempty,argGhcFlags=mempty,argGhcLibDir=mempty,argTargets=mempty}mappendab=HaddockArgs{argInterfaceFile=multargInterfaceFile,argPackageName=multargPackageName,argHideModules=multargHideModules,argIgnoreExports=multargIgnoreExports,argLinkSource=multargLinkSource,argCssFile=multargCssFile,argVerbose=multargVerbose,argOutput=multargOutput,argInterfaces=multargInterfaces,argOutputDir=multargOutputDir,argTitle=multargTitle,argPrologue=multargPrologue,argGhcFlags=multargGhcFlags,argGhcLibDir=multargGhcLibDir,argTargets=multargTargets}wheremultf=fa`mappend`fbinstanceMonoidDirectorywheremempty=Dir"."mappend(Dirm)(Dirn)=Dir$m</>n