From ae3690c2349b595a1fb459a4374cfe2e668a04aa Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 2 Oct 2012 00:47:46 +0200 Subject: Export Haddock's main entry point from library --- src/Documentation/Haddock.hs | 7 +- src/Haddock.hs | 461 +++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 458 ------------------------------------------ 3 files changed, 465 insertions(+), 461 deletions(-) create mode 100644 src/Haddock.hs delete mode 100644 src/Main.hs (limited to 'src') diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs index cbdc4d61..855cdc79 100644 --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -48,8 +48,10 @@ module Documentation.Haddock ( -- * Flags and options Flag(..), - DocOption(..) + DocOption(..), + -- * Program entry point + haddock, ) where @@ -58,7 +60,7 @@ import Haddock.Interface import Haddock.Types import Haddock.Options import Haddock.Utils -import Main +import Haddock -- | Create 'Interface' structures from a given list of Haddock command-line @@ -72,4 +74,3 @@ createInterfaces createInterfaces flags modules = do (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules) return ifaces - diff --git a/src/Haddock.hs b/src/Haddock.hs new file mode 100644 index 00000000..f53e01a9 --- /dev/null +++ b/src/Haddock.hs @@ -0,0 +1,461 @@ +{-# 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. +----------------------------------------------------------------------------- +module Haddock (haddock, readPackagesAndProcessModules, withGhc') where + + +import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Themes (getThemes) +import Haddock.Backends.LaTeX +import Haddock.Backends.Hoogle +import Haddock.Interface +import Haddock.Lex +import Haddock.Parse +import Haddock.Types +import Haddock.Version +import Haddock.InterfaceFile +import Haddock.Options +import Haddock.Utils +import Haddock.GhcUtils hiding (pretty) + +import Control.Monad +import Control.Exception +import Data.Maybe +import Data.IORef +import qualified Data.Map as Map +import System.IO +import System.Exit + +#if defined(mingw32_HOST_OS) +import Foreign +import Foreign.C +import Data.Int +#endif + +#ifdef IN_GHC_TREE +import System.FilePath +#else +import qualified GHC.Paths as GhcPaths +import Paths_haddock +#endif + +import GHC hiding (flags, verbosity) +import Config +import DynFlags hiding (flags, verbosity) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) +import Panic (panic, handleGhcException) +import Module + +import Control.Monad.Fix (MonadFix) + + +-------------------------------------------------------------------------------- +-- * Exception handling +-------------------------------------------------------------------------------- + + +handleTopExceptions :: IO a -> IO a +handleTopExceptions = + handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions + + +-- | Either returns normally or throws an ExitCode exception; +-- all other exceptions are turned into exit exceptions. +handleNormalExceptions :: IO a -> IO a +handleNormalExceptions inner = + (inner `onException` hFlush stdout) + `catches` + [ Handler (\(code :: ExitCode) -> exitWith code) + + , Handler (\(ex :: AsyncException) -> + case ex of + StackOverflow -> do + putStrLn "stack overflow: use -g +RTS -K to increase it" + exitFailure + _ -> do + putStrLn ("haddock: " ++ show ex) + exitFailure) + + , Handler (\(ex :: SomeException) -> do + putStrLn ("haddock: internal error: " ++ show ex) + exitFailure) + ] + + +handleHaddockExceptions :: IO a -> IO a +handleHaddockExceptions inner = + catches inner [Handler handler] + where + handler (e::HaddockException) = do + putStrLn $ "haddock: " ++ show e + exitFailure + + +handleGhcExceptions :: IO a -> IO a +handleGhcExceptions = + -- error messages propagated as exceptions + handleGhcException $ \e -> do + hFlush stdout + case e of + PhaseFailed _ code -> exitWith code + _ -> do + print (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 >>= haddock +haddock :: [String] -> IO () +haddock args = 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) <- parseHaddockOpts args + shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} + + withGhc' flags $ do + + dflags <- getDynFlags + + if not (null files) then do + (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + + -- Dump an "interface file" (.haddock file), if requested. + case optDumpInterfaceFile flags of + Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks + Nothing -> return () + + -- Render the interfaces. + liftIO $ renderStep dflags flags qual packages ifaces + + else do + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + throwE "No input file(s)." + + -- Get packages supplied with --read-interface. + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + + -- Render even though there are no input files (usually contents/index). + liftIO $ renderStep dflags flags qual packages [] + + +withGhc' :: [Flag] -> Ghc a -> IO a +withGhc' flags action = do + libDir <- fmap snd (getGhcDirs flags) + + -- Catches all GHC source errors, then prints and re-throws them. + let handleSrcErrors action' = flip handleSourceError action' $ \err -> do + printException err + liftIO exitFailure + + withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action) + + +readPackagesAndProcessModules :: [Flag] -> [String] + -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) +readPackagesAndProcessModules flags files = do + -- Get packages supplied with --read-interface. + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + + -- Create the interfaces -- this is the core part of Haddock. + let ifaceFiles = map snd packages + (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles + + return (packages, ifaces, homeLinks) + + +renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags qual pkgs interfaces = do + updateHTMLXRefs pkgs + let + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles + srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] + render dflags flags qual interfaces installedIfaces srcMap + + +-- | Render the interfaces with whatever backend is specified in the flags. +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render dflags flags qual ifaces installedIfaces srcMap = do + + let + title = fromMaybe "" (optTitle flags) + unicode = Flag_UseUnicode `elem` flags + pretty = Flag_PrettyHtml `elem` flags + opt_wiki_urls = wikiUrls flags + opt_contents_url = optContentsUrl flags + opt_index_url = optIndexUrl flags + odir = outputDir flags + opt_latex_style = optLaTeXStyle flags + + visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] + + -- /All/ visible interfaces including external package modules. + allIfaces = map toInstalledIface ifaces ++ installedIfaces + allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + + pkgMod = ifaceMod (head ifaces) + pkgId = modulePackageId pkgMod + pkgStr = Just (packageIdString pkgId) + (pkgName,pkgVer) = modulePackageInfo pkgMod + + (srcBase, srcModule, srcEntity) = sourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity + sourceUrls' = (srcBase, srcModule, srcMap') + + libDir <- getHaddockLibDir flags + prologue <- getPrologue flags + themes <- getThemes libDir flags >>= either bye return + + when (Flag_GenIndex `elem` flags) $ do + ppHtmlIndex odir title pkgStr + themes opt_contents_url sourceUrls' opt_wiki_urls + allVisibleIfaces pretty + copyHtmlBits odir libDir themes + + when (Flag_GenContents `elem` flags) $ do + ppHtmlContents odir title pkgStr + themes opt_index_url sourceUrls' opt_wiki_urls + allVisibleIfaces True prologue pretty + (makeContentsQual qual) + copyHtmlBits odir libDir themes + + when (Flag_Html `elem` flags) $ do + ppHtml title pkgStr visibleIfaces odir + prologue + themes sourceUrls' opt_wiki_urls + opt_contents_url opt_index_url unicode qual + pretty + copyHtmlBits odir libDir themes + + when (Flag_Hoogle `elem` flags) $ do + let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName + ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir + + when (Flag_LaTeX `elem` flags) $ do + ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style + libDir + + +------------------------------------------------------------------------------- +-- * Reading and dumping interface files +------------------------------------------------------------------------------- + + +readInterfaceFiles :: (MonadFix m, MonadIO m) => + NameCacheAccessor m + -> [(DocPaths, FilePath)] -> + m [(DocPaths, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs = do + mbPackages <- mapM tryReadIface pairs + return (catMaybes mbPackages) + where + -- try to read an interface, warn if we can't + tryReadIface (paths, file) = do + eIface <- readInterfaceFile name_cache_accessor file + case eIface of + Left err -> liftIO $ do + putStrLn ("Warning: Cannot read " ++ file ++ ":") + putStrLn (" " ++ err) + putStrLn "Skipping this interface." + return Nothing + Right f -> return $ Just (paths, f) + + +dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO () +dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile + where + ifaceFile = 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 -> Ghc a) -> IO a +withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do + -- TODO: handle warnings? + (restFlags, _) <- parseStaticFlags (map noLoc flags) + runGhc (Just libDir) $ do + dynflags <- getSessionDynFlags + let dynflags' = dopt_set dynflags Opt_Haddock + let dynflags'' = dynflags' { + hscTarget = HscNothing, + ghcMode = CompManager, + ghcLink = NoLink + } + dynflags''' <- parseGhcFlags dynflags'' restFlags flags + defaultCleanupHandler dynflags''' $ 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! + _ <- setSessionDynFlags dynflags''' + ghcActs dynflags''' + `finally` restoreStaticFlagGlobals savedFlags + where + parseGhcFlags :: Monad m => DynFlags -> [Located String] + -> [String] -> m DynFlags + parseGhcFlags dynflags flags_ origFlags = do + -- TODO: handle warnings? + (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ + if not (null rest) + then throwE ("Couldn't parse GHC options: " ++ unwords origFlags) + else return dynflags' + + +------------------------------------------------------------------------------- +-- * Misc +------------------------------------------------------------------------------- + + +getHaddockLibDir :: [Flag] -> IO String +getHaddockLibDir flags = + case [str | Flag_Lib str <- flags] of + [] -> +#ifdef IN_GHC_TREE + getInTreeDir +#else + getDataDir -- provided by Cabal +#endif + fs -> return (last fs) + + +getGhcDirs :: [Flag] -> IO (String, String) +getGhcDirs flags = do + case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> do +#ifdef IN_GHC_TREE + libDir <- getInTreeDir + return (ghcPath, libDir) +#else + return (ghcPath, GhcPaths.libdir) +#endif + xs -> return (ghcPath, last xs) + where +#ifdef IN_GHC_TREE + ghcPath = "not available" +#else + ghcPath = GhcPaths.ghc +#endif + + +shortcutFlags :: [Flag] -> IO () +shortcutFlags flags = do + usage <- getUsage + + when (Flag_Help `elem` flags) (bye usage) + when (Flag_Version `elem` flags) byeVersion + when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) + when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) + + when (Flag_PrintGhcPath `elem` flags) $ do + dir <- fmap fst (getGhcDirs flags) + bye $ dir ++ "\n" + + when (Flag_PrintGhcLibDir `elem` flags) $ do + dir <- fmap snd (getGhcDirs flags) + 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" + where + byeVersion = 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 () +updateHTMLXRefs packages = do + writeIORef html_xrefs_ref (Map.fromList mapping) + writeIORef html_xrefs_ref' (Map.fromList mapping') + where + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + , iface <- ifInstalledIfaces ifaces ] + mapping' = [ (moduleName m, html) | (m, html) <- mapping ] + + +getPrologue :: [Flag] -> IO (Maybe (Doc RdrName)) +getPrologue flags = + case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> do + str <- readFile filename + case parseParas (tokenise (defaultDynFlags (panic "No settings")) str + (1,0) {- TODO: real position -}) of + Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename + Just doc -> return (Just doc) + _otherwise -> throwE "multiple -p/--prologue options" + + +#ifdef IN_GHC_TREE + +getInTreeDir :: IO String +getInTreeDir = do + m <- getExecDir + case m of + Nothing -> error "No GhcDir found" + Just d -> return (d ".." "lib") + + +getExecDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 +#else +getExecDir = return Nothing +#endif + +#endif + diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index abeda77f..00000000 --- a/src/Main.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Main --- 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. ------------------------------------------------------------------------------ -module Main (main, readPackagesAndProcessModules, withGhc') where - - -import Haddock.Backends.Xhtml -import Haddock.Backends.Xhtml.Themes (getThemes) -import Haddock.Backends.LaTeX -import Haddock.Backends.Hoogle -import Haddock.Interface -import Haddock.Lex -import Haddock.Parse -import Haddock.Types -import Haddock.Version -import Haddock.InterfaceFile -import Haddock.Options -import Haddock.Utils -import Haddock.GhcUtils hiding (pretty) - -import Control.Monad -import Control.Exception -import Data.Maybe -import Data.IORef -import qualified Data.Map as Map -import System.IO -import System.Exit -import System.Environment - -#if defined(mingw32_HOST_OS) -import Foreign -import Foreign.C -import Data.Int -#endif - -#ifdef IN_GHC_TREE -import System.FilePath -#else -import qualified GHC.Paths as GhcPaths -import Paths_haddock -#endif - -import GHC hiding (flags, verbosity) -import Config -import DynFlags hiding (flags, verbosity) -import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) -import Panic (panic, handleGhcException) -import Module - -import Control.Monad.Fix (MonadFix) - - --------------------------------------------------------------------------------- --- * Exception handling --------------------------------------------------------------------------------- - - -handleTopExceptions :: IO a -> IO a -handleTopExceptions = - handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions - - --- | Either returns normally or throws an ExitCode exception; --- all other exceptions are turned into exit exceptions. -handleNormalExceptions :: IO a -> IO a -handleNormalExceptions inner = - (inner `onException` hFlush stdout) - `catches` - [ Handler (\(code :: ExitCode) -> exitWith code) - - , Handler (\(ex :: AsyncException) -> - case ex of - StackOverflow -> do - putStrLn "stack overflow: use -g +RTS -K to increase it" - exitFailure - _ -> do - putStrLn ("haddock: " ++ show ex) - exitFailure) - - , Handler (\(ex :: SomeException) -> do - putStrLn ("haddock: internal error: " ++ show ex) - exitFailure) - ] - - -handleHaddockExceptions :: IO a -> IO a -handleHaddockExceptions inner = - catches inner [Handler handler] - where - handler (e::HaddockException) = do - putStrLn $ "haddock: " ++ show e - exitFailure - - -handleGhcExceptions :: IO a -> IO a -handleGhcExceptions = - -- error messages propagated as exceptions - handleGhcException $ \e -> do - hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure - - -------------------------------------------------------------------------------- --- * Top level -------------------------------------------------------------------------------- - - -main :: IO () -main = 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. - args <- getArgs - (flags, files) <- parseHaddockOpts args - shortcutFlags flags - qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} - - withGhc' flags $ do - - dflags <- getDynFlags - - if not (null files) then do - (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files - - -- Dump an "interface file" (.haddock file), if requested. - case optDumpInterfaceFile flags of - Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks - Nothing -> return () - - -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces - - else do - when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ - throwE "No input file(s)." - - -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) - - -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags qual packages [] - - -withGhc' :: [Flag] -> Ghc a -> IO a -withGhc' flags action = do - libDir <- fmap snd (getGhcDirs flags) - - -- Catches all GHC source errors, then prints and re-throws them. - let handleSrcErrors action' = flip handleSourceError action' $ \err -> do - printException err - liftIO exitFailure - - withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action) - - -readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) -readPackagesAndProcessModules flags files = do - -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) - - -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map snd packages - (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles - - return (packages, ifaces, homeLinks) - - -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do - updateHTMLXRefs pkgs - let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap - - --- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do - - let - title = fromMaybe "" (optTitle flags) - unicode = Flag_UseUnicode `elem` flags - pretty = Flag_PrettyHtml `elem` flags - opt_wiki_urls = wikiUrls flags - opt_contents_url = optContentsUrl flags - opt_index_url = optIndexUrl flags - odir = outputDir flags - opt_latex_style = optLaTeXStyle flags - - visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - - pkgMod = ifaceMod (head ifaces) - pkgId = modulePackageId pkgMod - pkgStr = Just (packageIdString pkgId) - (pkgName,pkgVer) = modulePackageInfo pkgMod - - (srcBase, srcModule, srcEntity) = sourceUrls flags - srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity - sourceUrls' = (srcBase, srcModule, srcMap') - - libDir <- getHaddockLibDir flags - prologue <- getPrologue flags - themes <- getThemes libDir flags >>= either bye return - - when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title pkgStr - themes opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty - copyHtmlBits odir libDir themes - - when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title pkgStr - themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty - (makeContentsQual qual) - copyHtmlBits odir libDir themes - - when (Flag_Html `elem` flags) $ do - ppHtml title pkgStr visibleIfaces odir - prologue - themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes - - when (Flag_Hoogle `elem` flags) $ do - let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir - - when (Flag_LaTeX `elem` flags) $ do - ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style - libDir - - -------------------------------------------------------------------------------- --- * Reading and dumping interface files -------------------------------------------------------------------------------- - - -readInterfaceFiles :: (MonadFix m, MonadIO m) => - NameCacheAccessor m - -> [(DocPaths, FilePath)] -> - m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do - mbPackages <- mapM tryReadIface pairs - return (catMaybes mbPackages) - where - -- try to read an interface, warn if we can't - tryReadIface (paths, file) = do - eIface <- readInterfaceFile name_cache_accessor file - case eIface of - Left err -> liftIO $ do - putStrLn ("Warning: Cannot read " ++ file ++ ":") - putStrLn (" " ++ err) - putStrLn "Skipping this interface." - return Nothing - Right f -> return $ Just (paths, f) - - -dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO () -dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile - where - ifaceFile = 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 -> Ghc a) -> IO a -withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do - -- TODO: handle warnings? - (restFlags, _) <- parseStaticFlags (map noLoc flags) - runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - let dynflags' = dopt_set dynflags Opt_Haddock - let dynflags'' = dynflags' { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - dynflags''' <- parseGhcFlags dynflags'' restFlags flags - defaultCleanupHandler dynflags''' $ 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! - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' - `finally` restoreStaticFlagGlobals savedFlags - where - parseGhcFlags :: Monad m => DynFlags -> [Located String] - -> [String] -> m DynFlags - parseGhcFlags dynflags flags_ origFlags = do - -- TODO: handle warnings? - (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ - if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ unwords origFlags) - else return dynflags' - - -------------------------------------------------------------------------------- --- * Misc -------------------------------------------------------------------------------- - - -getHaddockLibDir :: [Flag] -> IO String -getHaddockLibDir flags = - case [str | Flag_Lib str <- flags] of - [] -> -#ifdef IN_GHC_TREE - getInTreeDir -#else - getDataDir -- provided by Cabal -#endif - fs -> return (last fs) - - -getGhcDirs :: [Flag] -> IO (String, String) -getGhcDirs flags = do - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> do -#ifdef IN_GHC_TREE - libDir <- getInTreeDir - return (ghcPath, libDir) -#else - return (ghcPath, GhcPaths.libdir) -#endif - xs -> return (ghcPath, last xs) - where -#ifdef IN_GHC_TREE - ghcPath = "not available" -#else - ghcPath = GhcPaths.ghc -#endif - - -shortcutFlags :: [Flag] -> IO () -shortcutFlags flags = do - usage <- getUsage - - when (Flag_Help `elem` flags) (bye usage) - when (Flag_Version `elem` flags) byeVersion - when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) - when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) - - when (Flag_PrintGhcPath `elem` flags) $ do - dir <- fmap fst (getGhcDirs flags) - bye $ dir ++ "\n" - - when (Flag_PrintGhcLibDir `elem` flags) $ do - dir <- fmap snd (getGhcDirs flags) - 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" - where - byeVersion = 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 () -updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') - where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages - , iface <- ifInstalledIfaces ifaces ] - mapping' = [ (moduleName m, html) | (m, html) <- mapping ] - - -getPrologue :: [Flag] -> IO (Maybe (Doc RdrName)) -getPrologue flags = - case [filename | Flag_Prologue filename <- flags ] of - [] -> return Nothing - [filename] -> do - str <- readFile filename - case parseParas (tokenise (defaultDynFlags (panic "No settings")) str - (1,0) {- TODO: real position -}) of - Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename - Just doc -> return (Just doc) - _otherwise -> throwE "multiple -p/--prologue options" - - -#ifdef IN_GHC_TREE - -getInTreeDir :: IO String -getInTreeDir = do - m <- getExecDir - case m of - Nothing -> error "No GhcDir found" - Just d -> return (d ".." "lib") - - -getExecDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) -getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf - | otherwise -> try_size (size * 2) - -foreign import stdcall unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 -#else -getExecDir = return Nothing -#endif - -#endif - -- cgit v1.2.3