module Main (main) where
import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
import Haddock.Options
import Haddock.GHC
import Haddock.Utils
import Paths_haddock
import Control.Monad
#if __GLASGOW_HASKELL__ >= 609
import Control.OldException
import qualified Control.Exception as NewException
#else
import Control.Exception
#endif
import Data.Dynamic
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import Data.Version
import System.IO
import System.Exit
import System.Environment
import System.FilePath
#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C
import Data.Int
#endif
#ifndef IN_GHC_TREE
import GHC.Paths
#endif
import GHC
import DynFlags
import Bag
import ErrUtils
#if __GLASGOW_HASKELL__ >= 609
import Panic (handleGhcException)
import Util
import MonadUtils ( MonadIO(..) )
#else
import Util hiding (handle)
#endif
handleTopExceptions =
handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions
handleNormalExceptions inner =
handle (\exception -> do
hFlush stdout
case exception of
AsyncException StackOverflow -> do
putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
exitFailure
ExitException code -> exitWith code
_other -> do
putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)
exitFailure
) inner
handleHaddockExceptions inner =
#if __GLASGOW_HASKELL__ >= 609
NewException.catches inner [NewException.Handler handler]
#else
handleDyn handler inner
#endif
where
handler (e::HaddockException) = do
putStrLn $ "haddock: " ++ (show e)
exitFailure
handleGhcExceptions inner =
#if __GLASGOW_HASKELL__ < 609
handleDyn (\e -> do
putStrLn "haddock: Compilation error(s):"
printBagOfErrors defaultDynFlags (unitBag e)
exitFailure
) $
#endif
#if __GLASGOW_HASKELL__ >= 609
handleGhcException (\e -> do
#else
handleDyn (\e -> do
#endif
hFlush stdout
case e of
PhaseFailed _ code -> exitWith code
Interrupted -> exitFailure
_ -> do
print (e :: GhcException)
exitFailure
) inner
main :: IO ()
main = handleTopExceptions $ do
args <- getArgs
(flags, fileArgs) <- parseHaddockOpts args
handleEasyFlags flags fileArgs
let renderStep packages interfaces = do
updateHTMLXRefs packages
let ifaceFiles = map fst packages
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
render flags interfaces installedIfaces
if not (null fileArgs)
then do
libDir <- case getGhcLibDir flags of
Just dir -> return dir
Nothing ->
#ifdef IN_GHC_TREE
do m <- getExecDir
case m of
Nothing -> error "No GhcLibDir found"
Just d -> return (d </> "..")
#else
return libdir
#endif
#if __GLASGOW_HASKELL__ >= 609
let handleSrcErrors action = flip handleSourceError action $ \err -> do
printExceptionAndWarnings err
liftIO exitFailure
startGhc libDir (ghcFlags flags) $ \dynflags -> handleSrcErrors $ do
packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
(interfaces, homeLinks) <- createInterfaces fileArgs flags
(map fst packages)
liftIO $ do
renderStep packages interfaces
dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
#else
(session, dynflags) <- startGhc libDir (ghcFlags flags)
packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
(interfaces, homeLinks) <- createInterfaces session fileArgs flags
(map fst packages)
renderStep packages interfaces
dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
#endif
else do
packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
renderStep packages []
render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
render flags ifaces installedIfaces = do
let
title = case [str | Flag_Heading str <- flags] of
[] -> ""
(t:_) -> t
maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags]
,listToMaybe [str | Flag_SourceModuleURL str <- flags]
,listToMaybe [str | Flag_SourceEntityURL str <- flags])
maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags]
,listToMaybe [str | Flag_WikiModuleURL str <- flags]
,listToMaybe [str | Flag_WikiEntityURL str <- flags])
verbose = Flag_Verbose `elem` flags
libdir <- case [str | Flag_Lib str <- flags] of
[] ->
#ifdef IN_GHC_TREE
do m <- getExecDir
case m of
Nothing -> error "No libdir found"
Just d -> return (d </> "..")
#else
getDataDir
#endif
fs -> return (last fs)
let css_file = case [str | Flag_CSS str <- flags] of
[] -> Nothing
fs -> Just (last fs)
odir <- case [str | Flag_OutputDir str <- flags] of
[] -> return "."
fs -> return (last fs)
let
maybe_contents_url =
case [url | Flag_UseContents url <- flags] of
[] -> Nothing
us -> Just (last us)
maybe_index_url =
case [url | Flag_UseIndex url <- flags] of
[] -> Nothing
us -> Just (last us)
maybe_html_help_format =
case [hhformat | Flag_HtmlHelp hhformat <- flags] of
[] -> Nothing
formats -> Just (last formats)
prologue <- getPrologue flags
let
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
allIfaces = map toInstalledIface ifaces ++ installedIfaces
allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
packageMod = ifaceMod (head ifaces)
packageStr = Just (modulePackageString packageMod)
(pkgName,pkgVer) = modulePackageInfo packageMod
when (Flag_GenIndex `elem` flags) $ do
ppHtmlIndex odir title packageStr maybe_html_help_format
maybe_contents_url maybe_source_urls maybe_wiki_urls
allVisibleIfaces
copyHtmlBits odir libdir css_file
when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []
when (Flag_GenContents `elem` flags) $ do
ppHtmlContents odir title packageStr maybe_html_help_format
maybe_index_url maybe_source_urls maybe_wiki_urls
allVisibleIfaces True prologue
copyHtmlBits odir libdir css_file
when (Flag_Html `elem` flags) $ do
ppHtml title packageStr visibleIfaces odir
prologue maybe_html_help_format
maybe_source_urls maybe_wiki_urls
maybe_contents_url maybe_index_url
copyHtmlBits odir libdir css_file
when (Flag_Hoogle `elem` flags) $ do
let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
readInterfaceFiles :: MonadIO m =>
NameCacheAccessor m
-> [(FilePath, FilePath)] ->
m [(InterfaceFile, FilePath)]
readInterfaceFiles name_cache_accessor pairs = do
mbPackages <- mapM tryReadIface pairs
return (catMaybes mbPackages)
where
tryReadIface (html, iface) = do
eIface <- readInterfaceFile name_cache_accessor iface
case eIface of
Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ iface ++ ":")
putStrLn (" " ++ show err)
putStrLn "Skipping this interface."
return Nothing
Right iface -> return $ Just (iface, html)
dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile ifaces homeLinks flags =
case [str | Flag_DumpInterface str <- flags] of
[] -> return ()
fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
where
ifaceFile = InterfaceFile {
ifInstalledIfaces = ifaces,
ifLinkEnv = homeLinks
}
getGhcLibDir flags =
case [ dir | Flag_GhcLibDir dir <- flags ] of
[] -> Nothing
xs -> Just $ last xs
handleEasyFlags flags fileArgs = do
usage <- getUsage
when (Flag_Help `elem` flags) (bye usage)
when (Flag_Version `elem` flags) byeVersion
when (Flag_GhcVersion `elem` flags) byeGhcVersion
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
throwE ("-h 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"
byeGhcVersion = bye $
(fromJust $ lookup "Project version" $ compilerInfo) ++ "\n"
updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
updateHTMLXRefs packages = do
writeIORef html_xrefs_ref (Map.fromList mapping)
where
mapping = [ (instMod iface, html) | (ifaces, html) <- packages,
iface <- ifInstalledIfaces ifaces ]
getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))
getPrologue flags
= case [filename | Flag_Prologue filename <- flags ] of
[] -> return Nothing
[filename] -> do
str <- readFile filename
case parseHaddockComment str of
Left err -> throwE err
Right doc -> return (Just doc)
_otherwise -> throwE "multiple -p/--prologue options"
getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
ret <- getModuleFileName nullPtr buf len
if ret == 0
then return Nothing
else do s <- peekCString buf
return (Just (dropFileName s))
where len = 2048
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir = return Nothing
#endif