diff options
Diffstat (limited to 'haddock-api/src/Haddock.hs')
| -rw-r--r-- | haddock-api/src/Haddock.hs | 488 |
1 files changed, 488 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs new file mode 100644 index 00000000..0cff5bd3 --- /dev/null +++ b/haddock-api/src/Haddock.hs @@ -0,0 +1,488 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2010, +-- Mateusz Kowalczyk 2014 +-- 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, + haddockWithGhc, + getGhcDirs, + 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.Parser +import Haddock.Types +import Haddock.Version +import Haddock.InterfaceFile +import Haddock.Options +import Haddock.Utils +import Haddock.GhcUtils hiding (pretty) + +import Control.Monad hiding (forM_) +import Data.Foldable (forM_) +import Data.List (isPrefixOf) +import Control.Exception +import Data.Maybe +import Data.IORef +import qualified Data.Map as Map +import System.IO +import System.Exit +import System.Directory + +#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_api (getDataDir) +#endif + +import GHC hiding (verbosity) +import Config +import DynFlags hiding (verbosity) +import StaticFlags (discardStaticFlags) +import Panic (handleGhcException) +import Module + +-------------------------------------------------------------------------------- +-- * 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<size> 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 = haddockWithGhc withGhc args + +haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO () +haddockWithGhc ghc 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} + + -- inject dynamic-too into flags before we proceed + flags' <- ghc flags $ do + df <- getDynFlags + case lookup "GHC Dynamic" (compilerInfo df) of + Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags + _ -> return flags + + unless (Flag_NoWarnings `elem` flags) $ do + forM_ (warnings args) $ \warning -> do + hPutStrLn stderr warning + + ghc flags' $ do + + dflags <- getDynFlags + + if not (null files) then do + (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + + -- Dump an "interface file" (.haddock file), if requested. + forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do + writeInterfaceFile path InterfaceFile { + ifInstalledIfaces = map toInstalledIface ifaces + , ifLinkEnv = homeLinks + } + + -- 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 [] + +-- | Create warnings about potential misuse of -optghc +warnings :: [String] -> [String] +warnings = map format . filter (isPrefixOf "-optghc") + where + format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] + + +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, srcLEntity) = sourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity + -- TODO: Get these from the interface files as with srcMap + srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity + sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') + + libDir <- getHaddockLibDir flags + prologue <- getPrologue dflags 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 :: MonadIO m + => NameCacheAccessor m + -> [(DocPaths, FilePath)] + -> m [(DocPaths, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs = do + catMaybes `liftM` mapM tryReadIface pairs + where + -- try to read an interface, warn if we can't + tryReadIface (paths, file) = + readInterfaceFile name_cache_accessor file >>= \case + Left err -> liftIO $ do + putStrLn ("Warning: Cannot read " ++ file ++ ":") + putStrLn (" " ++ err) + putStrLn "Skipping this interface." + return Nothing + Right f -> return $ Just (paths, f) + + +------------------------------------------------------------------------------- +-- * 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 = runGhc (Just libDir) $ do + dynflags <- getSessionDynFlags + dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { + hscTarget = HscNothing, + ghcMode = CompManager, + ghcLink = NoLink + } + let dynflags'' = gopt_unset dynflags' Opt_SplitObjs + 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'' + where + parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags + parseGhcFlags dynflags = do + -- TODO: handle warnings? + + -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot + -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if + -- we pass any, Haddock will fail. Since StaticFlags are global to the + -- GHC invocation, there's also no way to reparse/save them to set them + -- again properly. + -- + -- This is a bit of a hack until we get rid of the rest of the remaining + -- StaticFlags. See GHC issue #8276. + let flags' = discardStaticFlags flags + (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + if not (null rest) + then throwE ("Couldn't parse GHC options: " ++ unwords flags') + else return dynflags' + +------------------------------------------------------------------------------- +-- * Misc +------------------------------------------------------------------------------- + + +getHaddockLibDir :: [Flag] -> IO String +getHaddockLibDir flags = + case [str | Flag_Lib str <- flags] of + [] -> do +#ifdef IN_GHC_TREE + getInTreeDir +#else + d <- getDataDir -- provided by Cabal + doesDirectoryExist d >>= \exists -> case exists of + True -> return d + False -> do + -- If directory does not exist then we are probably invoking from + -- ./dist/build/haddock/haddock so we use ./resources as a fallback. + doesDirectoryExist "resources" >>= \exists_ -> case exists_ of + True -> return "resources" + False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n") +#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_CompatibleInterfaceVersions `elem` flags) + (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\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 :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName)) +getPrologue dflags flags = + case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> withFile filename ReadMode $ \h -> do + hSetEncoding h utf8 + str <- hGetContents h + return . Just $ parseParas dflags str + _ -> throwE "multiple -p/--prologue options" + + +#ifdef IN_GHC_TREE + +getInTreeDir :: IO String +getInTreeDir = getExecDir >>= \case + 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 |