{-# OPTIONS_GHC -Wwarn #-}{-# LANGUAGE CPP, ScopedTypeVariables #-}------------------------------------------------------------------------------- |-- Module : Haddock-- Copyright : (c) Simon Marlow 2003-2006,-- David Waern 2006-2010-- License : BSD-like---- Maintainer : haddock@projects.haskell.org-- Stability : experimental-- Portability : portable---- Haddock - A Haskell Documentation Tool---- Program entry point and top-level code.-----------------------------------------------------------------------------moduleHaddock(haddock,readPackagesAndProcessModules,withGhc')whereimportHaddock.Backends.XhtmlimportHaddock.Backends.Xhtml.Themes(getThemes)importHaddock.Backends.LaTeXimportHaddock.Backends.HoogleimportHaddock.InterfaceimportHaddock.LeximportHaddock.ParseimportHaddock.TypesimportHaddock.VersionimportHaddock.InterfaceFileimportHaddock.OptionsimportHaddock.UtilsimportHaddock.GhcUtilshiding(pretty)importControl.MonadimportControl.ExceptionimportData.MaybeimportData.IORefimportqualifiedData.MapasMapimportSystem.IOimportSystem.Exit#if defined(mingw32_HOST_OS)importForeignimportForeign.CimportData.Int#endif#ifdef IN_GHC_TREEimportSystem.FilePath#elseimportqualifiedGHC.PathsasGhcPathsimportPaths_haddock#endifimportGHChiding(flags,verbosity)importConfigimportDynFlagshiding(flags,verbosity)importStaticFlags(saveStaticFlagGlobals,restoreStaticFlagGlobals)importPanic(panic,handleGhcException)importModuleimportControl.Monad.Fix(MonadFix)---------------------------------------------------------------------------------- * Exception handling--------------------------------------------------------------------------------handleTopExceptions::IOa->IOahandleTopExceptions=handleNormalExceptions.handleHaddockExceptions.handleGhcExceptions-- | Either returns normally or throws an ExitCode exception;-- all other exceptions are turned into exit exceptions.handleNormalExceptions::IOa->IOahandleNormalExceptionsinner=(inner`onException`hFlushstdout)`catches`[Handler(\(code::ExitCode)->exitWithcode),Handler(\(ex::AsyncException)->caseexofStackOverflow->doputStrLn"stack overflow: use -g +RTS -K<size> to increase it"exitFailure_->doputStrLn("haddock: "++showex)exitFailure),Handler(\(ex::SomeException)->doputStrLn("haddock: internal error: "++showex)exitFailure)]handleHaddockExceptions::IOa->IOahandleHaddockExceptionsinner=catchesinner[Handlerhandler]wherehandler(e::HaddockException)=doputStrLn$"haddock: "++showeexitFailurehandleGhcExceptions::IOa->IOahandleGhcExceptions=-- error messages propagated as exceptionshandleGhcException$\e->dohFlushstdoutcaseeofPhaseFailed_code->exitWithcode_->doprint(e::GhcException)exitFailure--------------------------------------------------------------------------------- * Top level--------------------------------------------------------------------------------- | Run Haddock with given list of arguments.---- Haddock's own main function is defined in terms of this:---- > main = getArgs >>= haddockhaddock::[String]->IO()haddockargs=handleTopExceptions$do-- Parse command-line flags and handle some of them initially.-- TODO: unify all of this (and some of what's in the 'render' function),-- into one function that returns a record with a field for each option,-- or which exits with an error or help message.(flags,files)<-parseHaddockOptsargsshortcutFlagsflagsqual<-casequalificationflagsof{Leftmsg->throwEmsg;Rightq->returnq}withGhc'flags$dodflags<-getDynFlagsifnot(nullfiles)thendo(packages,ifaces,homeLinks)<-readPackagesAndProcessModulesflagsfiles-- Dump an "interface file" (.haddock file), if requested.caseoptDumpInterfaceFileflagsofJustf->liftIO$dumpInterfaceFilef(maptoInstalledIfaceifaces)homeLinksNothing->return()-- Render the interfaces.liftIO$renderStepdflagsflagsqualpackagesifaceselsedowhen(any(`elem`[Flag_Html,Flag_Hoogle,Flag_LaTeX])flags)$throwE"No input file(s)."-- Get packages supplied with --read-interface.packages<-liftIO$readInterfaceFilesfreshNameCache(readIfaceArgsflags)-- Render even though there are no input files (usually contents/index).liftIO$renderStepdflagsflagsqualpackages[]withGhc'::[Flag]->Ghca->IOawithGhc'flagsaction=dolibDir<-fmapsnd(getGhcDirsflags)-- Catches all GHC source errors, then prints and re-throws them.lethandleSrcErrorsaction'=fliphandleSourceErroraction'$\err->doprintExceptionerrliftIOexitFailurewithGhclibDir(ghcFlagsflags)(\_->handleSrcErrorsaction)readPackagesAndProcessModules::[Flag]->[String]->Ghc([(DocPaths,InterfaceFile)],[Interface],LinkEnv)readPackagesAndProcessModulesflagsfiles=do-- Get packages supplied with --read-interface.packages<-readInterfaceFilesnameCacheFromGhc(readIfaceArgsflags)-- Create the interfaces -- this is the core part of Haddock.letifaceFiles=mapsndpackages(ifaces,homeLinks)<-processModules(verbosityflags)filesflagsifaceFilesreturn(packages,ifaces,homeLinks)renderStep::DynFlags->[Flag]->QualOption->[(DocPaths,InterfaceFile)]->[Interface]->IO()renderStepdflagsflagsqualpkgsinterfaces=doupdateHTMLXRefspkgsletifaceFiles=mapsndpkgsinstalledIfaces=concatMapifInstalledIfacesifaceFilessrcMap=Map.fromList[(ifPackageIdif_,x)|((_,Justx),if_)<-pkgs]renderdflagsflagsqualinterfacesinstalledIfacessrcMap-- | Render the interfaces with whatever backend is specified in the flags.render::DynFlags->[Flag]->QualOption->[Interface]->[InstalledInterface]->SrcMap->IO()renderdflagsflagsqualifacesinstalledIfacessrcMap=dolettitle=fromMaybe""(optTitleflags)unicode=Flag_UseUnicode`elem`flagspretty=Flag_PrettyHtml`elem`flagsopt_wiki_urls=wikiUrlsflagsopt_contents_url=optContentsUrlflagsopt_index_url=optIndexUrlflagsodir=outputDirflagsopt_latex_style=optLaTeXStyleflagsvisibleIfaces=[i|i<-ifaces,OptHide`notElem`ifaceOptionsi]-- /All/ visible interfaces including external package modules.allIfaces=maptoInstalledIfaceifaces++installedIfacesallVisibleIfaces=[i|i<-allIfaces,OptHide`notElem`instOptionsi]pkgMod=ifaceMod(headifaces)pkgId=modulePackageIdpkgModpkgStr=Just(packageIdStringpkgId)(pkgName,pkgVer)=modulePackageInfopkgMod(srcBase,srcModule,srcEntity)=sourceUrlsflagssrcMap'=maybesrcMap(\path->Map.insertpkgIdpathsrcMap)srcEntitysourceUrls'=(srcBase,srcModule,srcMap')libDir<-getHaddockLibDirflagsprologue<-getPrologueflagsthemes<-getThemeslibDirflags>>=eitherbyereturnwhen(Flag_GenIndex`elem`flags)$doppHtmlIndexodirtitlepkgStrthemesopt_contents_urlsourceUrls'opt_wiki_urlsallVisibleIfacesprettycopyHtmlBitsodirlibDirthemeswhen(Flag_GenContents`elem`flags)$doppHtmlContentsodirtitlepkgStrthemesopt_index_urlsourceUrls'opt_wiki_urlsallVisibleIfacesTrueprologuepretty(makeContentsQualqual)copyHtmlBitsodirlibDirthemeswhen(Flag_Html`elem`flags)$doppHtmltitlepkgStrvisibleIfacesodirprologuethemessourceUrls'opt_wiki_urlsopt_contents_urlopt_index_urlunicodequalprettycopyHtmlBitsodirlibDirthemeswhen(Flag_Hoogle`elem`flags)$doletpkgName2=ifpkgName=="main"&&title/=[]thentitleelsepkgNameppHoogledflagspkgName2pkgVertitleprologuevisibleIfacesodirwhen(Flag_LaTeX`elem`flags)$doppLaTeXtitlepkgStrvisibleIfacesodirprologueopt_latex_stylelibDir--------------------------------------------------------------------------------- * Reading and dumping interface files-------------------------------------------------------------------------------readInterfaceFiles::(MonadFixm,MonadIOm)=>NameCacheAccessorm->[(DocPaths,FilePath)]->m[(DocPaths,InterfaceFile)]readInterfaceFilesname_cache_accessorpairs=dombPackages<-mapMtryReadIfacepairsreturn(catMaybesmbPackages)where-- try to read an interface, warn if we can'ttryReadIface(paths,file)=doeIface<-readInterfaceFilename_cache_accessorfilecaseeIfaceofLefterr->liftIO$doputStrLn("Warning: Cannot read "++file++":")putStrLn(" "++err)putStrLn"Skipping this interface."returnNothingRightf->return$Just(paths,f)dumpInterfaceFile::FilePath->[InstalledInterface]->LinkEnv->IO()dumpInterfaceFilepathifaceshomeLinks=writeInterfaceFilepathifaceFilewhereifaceFile=InterfaceFile{ifInstalledIfaces=ifaces,ifLinkEnv=homeLinks}--------------------------------------------------------------------------------- * Creating a GHC session--------------------------------------------------------------------------------- | Start a GHC session with the -haddock flag set. Also turn off-- compilation and linking. Then run the given 'Ghc' action.withGhc::String->[String]->(DynFlags->Ghca)->IOawithGhclibDirflagsghcActs=saveStaticFlagGlobals>>=\savedFlags->do-- TODO: handle warnings?(restFlags,_)<-parseStaticFlags(mapnoLocflags)runGhc(JustlibDir)$dodynflags<-getSessionDynFlagsletdynflags'=dopt_setdynflagsOpt_Haddockletdynflags''=dynflags'{hscTarget=HscNothing,ghcMode=CompManager,ghcLink=NoLink}dynflags'''<-parseGhcFlagsdynflags''restFlagsflagsdefaultCleanupHandlerdynflags'''$do-- ignore the following return-value, which is a list of packages-- that may need to be re-linked: Haddock doesn't do any-- dynamic or static linking at all!_<-setSessionDynFlagsdynflags'''ghcActsdynflags'''`finally`restoreStaticFlagGlobalssavedFlagswhereparseGhcFlags::Monadm=>DynFlags->[LocatedString]->[String]->mDynFlagsparseGhcFlagsdynflagsflags_origFlags=do-- TODO: handle warnings?(dynflags',rest,_)<-parseDynamicFlagsdynflagsflags_ifnot(nullrest)thenthrowE("Couldn't parse GHC options: "++unwordsorigFlags)elsereturndynflags'--------------------------------------------------------------------------------- * Misc-------------------------------------------------------------------------------getHaddockLibDir::[Flag]->IOStringgetHaddockLibDirflags=case[str|Flag_Libstr<-flags]of[]->#ifdef IN_GHC_TREEgetInTreeDir#elsegetDataDir-- provided by Cabal#endiffs->return(lastfs)getGhcDirs::[Flag]->IO(String,String)getGhcDirsflags=docase[dir|Flag_GhcLibDirdir<-flags]of[]->do#ifdef IN_GHC_TREElibDir<-getInTreeDirreturn(ghcPath,libDir)#elsereturn(ghcPath,GhcPaths.libdir)#endifxs->return(ghcPath,lastxs)where#ifdef IN_GHC_TREEghcPath="not available"#elseghcPath=GhcPaths.ghc#endifshortcutFlags::[Flag]->IO()shortcutFlagsflags=dousage<-getUsagewhen(Flag_Help`elem`flags)(byeusage)when(Flag_Version`elem`flags)byeVersionwhen(Flag_InterfaceVersion`elem`flags)(bye(showbinaryInterfaceVersion++"\n"))when(Flag_GhcVersion`elem`flags)(bye(cProjectVersion++"\n"))when(Flag_PrintGhcPath`elem`flags)$dodir<-fmapfst(getGhcDirsflags)bye$dir++"\n"when(Flag_PrintGhcLibDir`elem`flags)$dodir<-fmapsnd(getGhcDirsflags)bye$dir++"\n"when(Flag_UseUnicode`elem`flags&&Flag_Html`notElem`flags)$throwE"Unicode can only be enabled for HTML output."when((Flag_GenIndex`elem`flags||Flag_GenContents`elem`flags)&&Flag_Html`elem`flags)$throwE"-h cannot be used with --gen-index or --gen-contents"when((Flag_GenIndex`elem`flags||Flag_GenContents`elem`flags)&&Flag_Hoogle`elem`flags)$throwE"--hoogle cannot be used with --gen-index or --gen-contents"when((Flag_GenIndex`elem`flags||Flag_GenContents`elem`flags)&&Flag_LaTeX`elem`flags)$throwE"--latex cannot be used with --gen-index or --gen-contents"wherebyeVersion=bye$"Haddock version "++projectVersion++", (c) Simon Marlow 2006\n"++"Ported to use the GHC API by David Waern 2006-2008\n"updateHTMLXRefs::[(DocPaths,InterfaceFile)]->IO()updateHTMLXRefspackages=dowriteIORefhtml_xrefs_ref(Map.fromListmapping)writeIORefhtml_xrefs_ref'(Map.fromListmapping')wheremapping=[(instModiface,html)|((html,_),ifaces)<-packages,iface<-ifInstalledIfacesifaces]mapping'=[(moduleNamem,html)|(m,html)<-mapping]getPrologue::[Flag]->IO(Maybe(DocRdrName))getPrologueflags=case[filename|Flag_Prologuefilename<-flags]of[]->returnNothing[filename]->dostr<-readFilefilenamecaseparseParas(tokenise(defaultDynFlags(panic"No settings"))str(1,0){- TODO: real position -})ofNothing->throwE$"failed to parse haddock prologue from file: "++filenameJustdoc->return(Justdoc)_otherwise->throwE"multiple -p/--prologue options"#ifdef IN_GHC_TREEgetInTreeDir::IOStringgetInTreeDir=dom<-getExecDircasemofNothing->error"No GhcDir found"Justd->return(d</>".."</>"lib")getExecDir::IO(MaybeString)#if defined(mingw32_HOST_OS)getExecDir=try_size2048-- plenty, PATH_MAX is 512 under Win32.wheretry_sizesize=allocaArray(fromIntegralsize)$\buf->doret<-c_GetModuleFileNamenullPtrbufsizecaseretof0->returnNothing_|ret<size->fmap(Just.dropFileName)$peekCWStringbuf|otherwise->try_size(size*2)foreignimportstdcallunsafe"windows.h GetModuleFileNameW"c_GetModuleFileName::Ptr()->CWString->Word32->IOWord32#elsegetExecDir=returnNothing#endif#endif