diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 313 |
1 files changed, 152 insertions, 161 deletions
diff --git a/src/Main.hs b/src/Main.hs index 944ee10f..5240e5c1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -31,13 +31,15 @@ import Data.Maybe ( Maybe(..), isJust, isNothing, maybeToList, import Data.Word import Data.Typeable import Data.Graph hiding ( flattenSCC ) +import Data.Dynamic +import Data.Foldable ( foldlM ) import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) import System.Environment ( getArgs ) import System.Directory ( doesDirectoryExist ) import System.FilePath import System.Cmd ( system ) -import System.Exit ( ExitCode(..) ) +import System.Exit import System.IO import qualified Data.Map as Map @@ -61,6 +63,8 @@ import PrelNames import Bag import Binary import HscTypes +import Util ( handleDyn ) +import ErrUtils ( printBagOfErrors ) import FastString #define FSLIT(x) (mkFastString# (x#)) @@ -70,172 +74,130 @@ import Packages hiding ( package ) import StaticFlags ( parseStaticFlags ) -------------------------------------------------------------------------------- --- Top-level stuff +-- Exception handling -------------------------------------------------------------------------------- -parseLibDir (('-':'B':libdir):rest) = (libdir,rest) -parseLibDir _ = die "Error: no -B<ghc_lib_dir> argument\n" +data HaddockException = HaddockException String deriving Typeable +throwE str = throwDyn (HaddockException str) + +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 = + handleDyn (\(HaddockException str) -> do + putStrLn $ "haddock: " ++ str + exitFailure + ) inner + +handleGhcExceptions inner = + -- compilation errors: messages with locations attached + handleDyn (\dyn -> do + putStrLn "haddock: Compilation error(s):" + printBagOfErrors defaultDynFlags (unitBag dyn) + exitFailure + ) $ + + -- error messages propagated as exceptions + handleDyn (\dyn -> do + hFlush stdout + case dyn of + PhaseFailed _ code -> exitWith code + Interrupted -> exitFailure + _ -> do + print (dyn :: GhcException) + exitFailure + ) inner + +-------------------------------------------------------------------------------- +-- Top-level +-------------------------------------------------------------------------------- main :: IO () -main = do +main = handleTopExceptions $ do args <- getArgs - let (libDir, args') = parseLibDir args - - -- find out which flag mode we are in - let (isGHCMode, rest) = parseModeFlag args' + prog <- getProgramName + -- parse flags and handle some of them initially + (flags, fileArgs) <- parseHaddockOpts args + libDir <- handleFlags flags fileArgs + -- initialize GHC (session, dynflags) <- startGHC libDir - - -- parse GHC flags given to the program - (dynflags', rest') <- if isGHCMode - then parseGHCFlags_GHCMode dynflags rest - else parseGHCFlags_HaddockMode dynflags rest + dynflags' <- parseGhcFlags dynflags flags setSessionDynFlags session dynflags' - -- parse Haddock specific flags - (flags, fileArgs) <- parseHaddockOpts rest' - - -- react to some flags before doing anything - handleEagerFlags flags - - -- create a PackageData for each external package in the session - -- using the GHC API. The PackageData contains an html path, - -- a doc env and a list of module names. + -- load package data (from .haddock-files), typecheck input files and create + -- the module -> html mapping packages <- getPackages session dynflags' flags - - -- try to sort and check the input files using the GHC API - modules <- sortAndCheckModules session dynflags' fileArgs - - -- update the html references (module -> html file mapping) + modules <- sortAndCheckModules session fileArgs updateHTMLXRefs packages -- combine the doc envs of the external packages into one let env = packagesDocEnv packages - -- TODO: continue to break up the run function into parts + -- TODO: continue to break up the run function into parts run flags modules env -parseModeFlag :: [String] -> (Bool, [String]) -parseModeFlag ("--ghc-flags":rest) = (True, rest) -parseModeFlag rest = (False, rest) - -parseGHCFlags_GHCMode :: DynFlags -> [String] -> IO (DynFlags, [String]) -parseGHCFlags_GHCMode dynflags args = do - (dynflags', rest) <- parseDynamicFlags dynflags args - rest' <- parseStaticFlags rest - return (dynflags', rest') - -parseGHCFlags_HaddockMode = parseGHCFlags - -parseGHCFlags :: DynFlags -> [String] -> IO (DynFlags, [String]) -parseGHCFlags dynflags args = case args of - [] -> return (dynflags, args) - ("-g":rest) -> worker rest - (('-':'-':'g':'h':'c':'-':'f':'l':'a':'g':'=':str):rest) -> worker (str:rest) - (x:xs) -> do - (flags, rest) <- parseGHCFlags dynflags xs - return (flags, x:rest) - where -{- worker strs = do - let (inside, _:outside) = break (=='"') (unwords strs) - (dynflags', rest) <- parseDynamicFlags dynflags (words inside) - when (rest == words inside) $ parseStaticFlags (words inside) >> return () - parseGHCFlags dynflags' (words outside) --} - worker rest = do - (mbFlags, rest') <- parseGHCFlag dynflags rest - case mbFlags of - Just flags -> parseGHCFlags flags rest' - Nothing -> parseGHCFlags dynflags rest' - -parseGHCFlag :: DynFlags -> [String] -> IO (Maybe DynFlags, [String]) -parseGHCFlag _ [] = die "No GHC flag supplied\n" -parseGHCFlag dynflags args = do - mbDyn <- findDynamic - case mbDyn of - Just (dynflags', rest) -> return (Just dynflags', rest) - Nothing -> do - mbStat <- findStatic - case mbStat of - Just (_, rest) -> return (Nothing, rest) - Nothing -> die ("Not a GHC flag: " ++ (head args) ++ "\n") - where - findDynamic = findFlag (\xs -> (do - (fs, xs') <- parseDynamicFlags dynflags xs - if xs' /= xs then return (Just fs) else return Nothing - ) `catch` (\_ -> return Nothing) - ) - - findStatic = findFlag (\xs -> do - xs' <- parseStaticFlags xs - if xs /= xs' then return (Just ()) else return Nothing - ) - - findFlag p = do - xs <- (sequence . snd) (mapAccumL (f p) [] args) - case [ (x, index) | Just x <- xs | index <- [1..] ] of - ((x, index):_) -> return (Just (x, drop index args)) - _ -> return Nothing - - f :: ([String] -> IO a) -> [String] -> String -> ([String], IO a) - f parser previousArgs arg = - let args' = previousArgs ++ [arg] - in (args', parser args') +handleFlags flags fileArgs = do + prog <- getProgramName + let byeUsage = bye (usageInfo (usageHeader prog) (options False)) + + when (Flag_Help `elem` flags) byeUsage + when (Flag_Version `elem` flags) byeVersion + when (null fileArgs) byeUsage + let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> throwE "no GHC lib dir specified" + xs -> last xs + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + throwE ("-h cannot be used with --gen-index or --gen-contents") + + return ghcLibDir + +-------------------------------------------------------------------------------- +-- Flags +-------------------------------------------------------------------------------- + +parseGhcFlags dflags flags = foldlM parseFlag dflags ghcFlags + where + -- a list of ghc flags with arguments, e.g. [[-o, odir],[-O]] + ghcFlags = [ words str | Flag_GhcFlag str <- flags ] + + -- try to parse a flag as either a dynamic or static GHC flag + parseFlag dynflags ghcFlag = do + (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag + when (rest == ghcFlag) $ do + rest' <- parseStaticFlags ghcFlag + when (rest' == ghcFlag) $ + throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) + return dynflags' + parseHaddockOpts :: [String] -> IO ([Flag], [String]) parseHaddockOpts words = case getOpt Permute (options True) words of (flags, args, []) -> return (flags, args) (_, _, errors) -> do prog <- getProgramName - die (concat errors ++ usageInfo (usageHeader prog) (options False)) + throwE (concat errors ++ usageInfo (usageHeader prog) (options False)) usageHeader :: String -> String usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" -extractGHCFlags :: [Flag] -> [String] -extractGHCFlags flags = [ flag | Flag_GHCFlag flag <- flags ] - -startGHC :: String -> IO (Session, DynFlags) -startGHC libDir = do - let ghcMode = BatchCompile - session <- newSession ghcMode (Just libDir) - flags <- getSessionDynFlags session - flags' <- liftM fst (initPackages flags) - let flags'' = dopt_set flags' Opt_Haddock - return (session, flags'') - -sortAndCheckModules :: Session -> DynFlags -> [FilePath] -> IO [CheckedMod] -sortAndCheckModules session flags files = defaultErrorHandler flags $ do - targets <- mapM (\s -> guessTarget s Nothing) files - setTargets session targets - mbModGraph <- depanal session [] True - moduleGraph <- case mbModGraph of - Just mg -> return mg - Nothing -> die "Failed to load all modules\n" - let - modSumFile = fromJust . ml_hs_file . ms_location - sortedGraph = topSortModuleGraph False moduleGraph Nothing - sortedModules = concatMap flattenSCC sortedGraph - modsAndFiles = [ (ms_mod modsum, modSumFile modsum) | - modsum <- sortedModules, - modSumFile modsum `elem` files ] - checkedMods <- mapM (\(mod, file) -> do - mbMod <- checkModule session (moduleName mod) - checkedMod <- case mbMod of - Just m -> return m - Nothing -> die ("Failed to load module: " ++ moduleString mod ++ "\n") - return (mod, file, checkedMod)) modsAndFiles - ensureFullyChecked checkedMods - where - ensureFullyChecked modules - | length modules' == length modules = return modules' - | otherwise = die "Failed to check all modules properly\n" - where modules' = [ (mod, f, (a,b,c,d)) | - (mod, f, CheckedModule a (Just b) (Just c) (Just d)) - <- modules ] - data Flag = Flag_CSS String | Flag_Debug @@ -265,12 +227,15 @@ data Flag | Flag_IgnoreAllExports | Flag_HideModule String | Flag_UsePackage String - | Flag_GHCFlag String + | Flag_GhcFlag String + | Flag_GhcLibDir String deriving (Eq) options :: Bool -> [OptDescr Flag] options backwardsCompat = [ + Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR") + "path to the GHC lib dir, e.g /usr/lib/ghc", Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") "directory in which to put the output files", Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") @@ -328,24 +293,53 @@ options backwardsCompat = "behave as if MODULE has the hide attribute", Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE") "the modules being processed depend on PACKAGE", - Option ['g'] ["ghc-flag"] (ReqArg Flag_GHCFlag "FLAG") - "send a flag to the Glasgow Haskell Compiler" - ] - -handleEagerFlags flags = do - when ((Flag_Help `elem` flags) || null flags) $ do - prog <- getProgramName - bye (usageInfo (usageHeader prog) (options False)) - - whenFlag Flag_Version $ - bye ("Haddock-GHC version " ++ projectVersion ++ - ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") + Option ['g'] [] (ReqArg Flag_GhcFlag "FLAGS + ARGS") + ("send a flag to the Glasgow Haskell Compiler (use quotation to " + ++ "pass arguments to the flag)") + ] - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - die ("-h cannot be used with --gen-index or --gen-contents") - where - whenFlag flag action = when (flag `elem` flags) action +byeVersion = + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n") + +startGHC :: String -> IO (Session, DynFlags) +startGHC libDir = do + let ghcMode = BatchCompile + session <- newSession ghcMode (Just libDir) + flags <- getSessionDynFlags session + flags' <- liftM fst (initPackages flags) + let flags'' = dopt_set flags' Opt_Haddock + return (session, flags'') + +sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod] +sortAndCheckModules session files = do + targets <- mapM (\s -> guessTarget s Nothing) files + setTargets session targets + mbModGraph <- depanal session [] True + moduleGraph <- case mbModGraph of + Just mg -> return mg + Nothing -> throwE "Failed to load all modules" + let + modSumFile = fromJust . ml_hs_file . ms_location + sortedGraph = topSortModuleGraph False moduleGraph Nothing + sortedModules = concatMap flattenSCC sortedGraph + modsAndFiles = [ (ms_mod modsum, modSumFile modsum) | + modsum <- sortedModules, + modSumFile modsum `elem` files ] + checkedMods <- mapM (\(mod, file) -> do + mbMod <- checkModule session (moduleName mod) + checkedMod <- case mbMod of + Just m -> return m + Nothing -> throwE ("Failed to load module: " ++ moduleString mod) + return (mod, file, checkedMod)) modsAndFiles + ensureFullyChecked checkedMods + where + ensureFullyChecked modules + | length modules' == length modules = return modules' + | otherwise = throwE "Failed to check all modules properly" + where modules' = [ (mod, f, (a,b,c,d)) | + (mod, f, CheckedModule a (Just b) (Just c) (Just d)) + <- modules ] run :: [Flag] -> [CheckedMod] -> Map Name Name -> IO () run flags modules extEnv = do @@ -766,9 +760,9 @@ getPrologue flags [filename] -> do str <- readFile filename case parseHaddockComment str of - Left err -> die err + Left err -> throwE err Right doc -> return (Just doc) - _otherwise -> die "multiple -p/--prologue options" + _otherwise -> throwE "multiple -p/--prologue options" -- ----------------------------------------------------------------------------- -- Phase 2 @@ -1214,9 +1208,6 @@ data PackageData = PackageData { pdHtmlPath :: FilePath } -data HaddockException = HaddockException String deriving Typeable -throwE str = throwDyn (HaddockException str) - -- | Recreate exposed modules from an InstalledPackageInfo packageModules :: InstalledPackageInfo -> [Module] packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames |