diff options
Diffstat (limited to 'src/Haddock.hs')
| -rw-r--r-- | src/Haddock.hs | 488 |
1 files changed, 0 insertions, 488 deletions
diff --git a/src/Haddock.hs b/src/Haddock.hs deleted file mode 100644 index 0cff5bd3..00000000 --- a/src/Haddock.hs +++ /dev/null @@ -1,488 +0,0 @@ -{-# 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 |