From c5eedeb72fe656e7bc6c5d21c0a4e91b93f386b6 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Sun, 14 Sep 2008 23:29:57 +0000 Subject: [PATCH] Use 'GhcMonad' in ghc/Main. --- ghc/Main.hs | 125 +++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 69 insertions(+), 56 deletions(-) diff --git a/ghc/Main.hs b/ghc/Main.hs index b75548b..c80ca78 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,7 +14,7 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( Session, DynFlags(..), HscTarget(..), +import GHC ( DynFlags(..), HscTarget(..), GhcMode(..), GhcLink(..), LoadHowMuch(..), dopt, DynFlag(..) ) import CmdLineParser @@ -34,16 +34,17 @@ import HscTypes import Packages ( dumpPackages ) import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) +import BasicTypes ( failed ) import StaticFlags import StaticFlagParser import DynFlags -import BasicTypes ( failed ) import ErrUtils import FastString import Outputable import SrcLoc import Util import Panic +import MonadUtils ( liftIO ) -- Standard Haskell libraries import System.IO @@ -68,8 +69,8 @@ import Data.Maybe main :: IO () main = - GHC.defaultErrorHandler defaultDynFlags $ do + GHC.defaultErrorHandler defaultDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -101,9 +102,9 @@ main = _ -> return () -- start our GHC session - session <- GHC.newSession mbMinusB + GHC.runGhc mbMinusB $ do - dflags0 <- GHC.getSessionDynFlags session + dflags0 <- GHC.getSessionDynFlags -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only @@ -112,21 +113,21 @@ main = let dflt_target = hscTarget dflags0 (mode, lang, link) = case cli_mode of - DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) - DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) - DoMake -> (CompManager, dflt_target, LinkBinary) - DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) - _ -> (OneShot, dflt_target, LinkBinary) + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) let dflags1 = dflags0{ ghcMode = mode, hscTarget = lang, ghcLink = link, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", - verbosity = case cli_mode of - DoEval _ -> 0 - _other -> 1 - } + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case cli_mode of + DoEval _ -> 0 + _other -> 1 + } -- turn on -fimplicit-import-qualified for GHCi now, so that it -- can be overriden from the command-line @@ -135,24 +136,24 @@ main = | otherwise = dflags1 where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified - -- The rest of the arguments are "dynamic" - -- Leftover ones are presumably files + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 let flagWarnings = staticFlagWarnings ++ modeFlagWarnings ++ dynamicFlagWarnings - handleFlagWarnings dflags2 flagWarnings + liftIO $ handleFlagWarnings dflags2 flagWarnings - -- make sure we clean up after ourselves + -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do - showBanner cli_mode dflags2 + liftIO $ showBanner cli_mode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags session dflags2 - dflags3 <- GHC.getSessionDynFlags session - hsc_env <- GHC.sessionHscEnv session + GHC.setSessionDynFlags dflags2 + dflags3 <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession let -- To simplify the handling of filepaths, we normalise all filepaths right @@ -163,40 +164,44 @@ main = -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on -- the command-line. - mapM_ (consIORef v_Ld_inputs) (reverse objs) + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) - ---------------- Display configuration ----------- + ---------------- Display configuration ----------- when (verbosity dflags3 >= 4) $ - dumpPackages dflags3 + liftIO $ dumpPackages dflags3 when (verbosity dflags3 >= 3) $ do - hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) - ---------------- Final sanity checking ----------- - checkOptions cli_mode dflags3 srcs objs + ---------------- Final sanity checking ----------- + liftIO $ checkOptions cli_mode dflags3 srcs objs ---------------- Do the business ----------- let alreadyHandled = panic (show cli_mode ++ " should already have been handled") - case cli_mode of - ShowUsage -> showGhcUsage dflags3 cli_mode - PrintLibdir -> putStrLn (topDir dflags3) - ShowSupportedLanguages -> alreadyHandled - ShowVersion -> alreadyHandled - ShowNumVersion -> alreadyHandled - ShowInterface f -> doShowIface dflags3 f - DoMake -> doMake session srcs - DoMkDependHS -> doMkDependHS session (map fst srcs) - StopBefore p -> oneShot hsc_env p srcs - DoInteractive -> interactiveUI session srcs Nothing - DoEval exprs -> interactiveUI session srcs $ Just $ reverse exprs - - dumpFinalStats dflags3 - exitWith ExitSuccess + + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ + case cli_mode of + ShowUsage -> liftIO $ showGhcUsage dflags3 cli_mode + PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + ShowSupportedLanguages -> alreadyHandled + ShowVersion -> alreadyHandled + ShowNumVersion -> alreadyHandled + ShowInterface f -> liftIO $ doShowIface dflags3 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoInteractive -> interactiveUI srcs Nothing + DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + + liftIO $ dumpFinalStats dflags3 + liftIO $ exitWith ExitSuccess #ifndef GHCI -interactiveUI :: a -> b -> c -> IO () -interactiveUI _ _ _ = +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = ghcError (CmdLineError "not built for interactive use") #endif @@ -244,6 +249,9 @@ looks_like_an_input m = isSourceFilename m -- ----------------------------------------------------------------------------- -- Option sanity checks +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). checkOptions cli_mode dflags srcs objs = do @@ -450,9 +458,9 @@ addFlag s = do -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = ghcError (UsageError "no input files") -doMake sess srcs = do +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake [] = ghcError (UsageError "no input files") +doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = @@ -460,14 +468,19 @@ doMake sess srcs = do haskellish (_,Just phase) = phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] - hsc_env <- GHC.sessionHscEnv sess - o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs - mapM_ (consIORef v_Ld_inputs) (reverse o_files) + hsc_env <- GHC.getSession + o_files <- mapM (\x -> do + f <- compileFile hsc_env StopLn x + GHC.printWarnings + return f) + non_hs_srcs + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) targets <- mapM (uncurry GHC.guessTarget) hs_srcs - GHC.setTargets sess targets - ok_flag <- GHC.load sess LoadAllTargets - when (failed ok_flag) (exitWith (ExitFailure 1)) + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) return () -- 1.7.10.4