X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=9c993345bb7fa093f2722e668466f637359a298d;hb=fd26d0ac1b48890dc7c3b5b60b42373fa964cdc8;hp=b7da083348096bb3e533e5cb4d44bc84bf6dc904;hpb=1f4bc1f36380776c68431dbc3b5fa41dd6d2182e;p=ghc-hetmet.git diff --git a/ghc/Main.hs b/ghc/Main.hs index b7da083..9c99334 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,8 +14,8 @@ module Main (main) where import qualified GHC import GHC ( -- DynFlags(..), HscTarget(..), -- GhcMode(..), GhcLink(..), - LoadHowMuch(..), -- dopt, DynFlag(..), - defaultCallbacks ) + Ghc, GhcMonad(..), + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -44,7 +44,7 @@ import Outputable import SrcLoc import Util import Panic --- import MonadUtils ( liftIO ) +import MonadUtils ( liftIO ) -- Imports for --abi-hash import LoadIface ( loadUserInterface ) @@ -105,7 +105,7 @@ main = do case mode of Left preStartupMode -> do case preStartupMode of - ShowSupportedLanguages -> showSupportedLanguages + ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion Print str -> putStrLn str @@ -167,9 +167,9 @@ main' postLoadMode dflags0 args flagWarnings = do let flagWarnings' = flagWarnings ++ dynamicFlagWarnings handleSourceError (\e -> do - GHC.printExceptionAndWarnings e - liftIO $ exitWith (ExitFailure 1)) $ - handleFlagWarnings dflags2 flagWarnings' + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags2 flagWarnings' -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do @@ -204,14 +204,13 @@ main' postLoadMode dflags0 args flagWarnings = do ---------------- Do the business ----------- handleSourceError (\e -> do - GHC.printExceptionAndWarnings e + GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags3 f DoMake -> doMake srcs - DoMkDependHS -> do doMkDependHS (map fst srcs) - GHC.printWarnings - StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> liftIO (oneShot hsc_env p srcs) DoInteractive -> interactiveUI srcs Nothing DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs DoAbiHash -> abiHash srcs @@ -351,13 +350,13 @@ type PostStartupMode = Either PreLoadMode PostLoadMode data PreStartupMode = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version - | ShowSupportedLanguages -- ghc --supported-languages + | ShowSupportedExtensions -- ghc --supported-extensions | Print String -- ghc --print-foo -showVersionMode, showNumVersionMode, showSupportedLanguagesMode :: Mode -showVersionMode = mkPreStartupMode ShowVersion -showNumVersionMode = mkPreStartupMode ShowNumVersion -showSupportedLanguagesMode = mkPreStartupMode ShowSupportedLanguages +showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions printMode :: String -> Mode printMode str = mkPreStartupMode (Print str) @@ -496,23 +495,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - Flag "?" (PassFlag (setMode showGhcUsageMode)) - Supported - , Flag "-help" (PassFlag (setMode showGhcUsageMode)) - Supported - , Flag "V" (PassFlag (setMode showVersionMode)) - Supported - , Flag "-version" (PassFlag (setMode showVersionMode)) - Supported - , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) - Supported - , Flag "-info" (PassFlag (setMode showInfoMode)) - Supported - , Flag "-supported-languages" (PassFlag (setMode showSupportedLanguagesMode)) - Supported + Flag "?" (PassFlag (setMode showGhcUsageMode)) + , Flag "-help" (PassFlag (setMode showGhcUsageMode)) + , Flag "V" (PassFlag (setMode showVersionMode)) + , Flag "-version" (PassFlag (setMode showVersionMode)) + , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ [ Flag k' (PassFlag (setMode mode)) - Supported | (k, v) <- compilerInfo, let k' = "-print-" ++ map (replaceSpace . toLower) k replaceSpace ' ' = '-' @@ -524,33 +516,23 @@ mode_flags = ------- interfaces ---------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) - Supported ------- primary modes ------------------------------------------------ , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f addFlag "-no-link" f)) - Supported , Flag "M" (PassFlag (setMode doMkDependHSMode)) - Supported , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - Supported , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f addFlag "-fvia-C" f)) - Supported , Flag "S" (PassFlag (setMode (stopBeforeMode As))) - Supported , Flag "-make" (PassFlag (setMode doMakeMode)) - Supported , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) - Supported , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) - Supported , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) - Supported ] -setMode :: Mode -> String -> ModeM () -setMode newMode newFlag = do +setMode :: Mode -> String -> EwM ModeM () +setMode newMode newFlag = liftEwM $ do (mModeFlag, errs, flags') <- getCmdLineState let (modeFlag', errs') = case mModeFlag of @@ -593,8 +575,8 @@ flagMismatchErr :: String -> String -> String flagMismatchErr oldFlag newFlag = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" -addFlag :: String -> String -> ModeM () -addFlag s flag = do +addFlag :: String -> String -> EwM ModeM () +addFlag s flag = liftEwM $ do (m, e, flags') <- getCmdLineState putCmdLineState (m, e, mkGeneralLocated loc s : flags') where loc = "addFlag by " ++ flag ++ " on the commandline" @@ -609,7 +591,7 @@ doMake srcs = do haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -618,13 +600,10 @@ doMake srcs = do -- This means that "ghc Foo.o Bar.o -o baz" links the program as -- we expect. if (null hs_srcs) - then oneShot hsc_env StopLn srcs >> GHC.printWarnings + then liftIO (oneShot hsc_env StopLn srcs) else do - o_files <- mapM (\x -> do - f <- compileFile hsc_env StopLn x - GHC.printWarnings - return f) + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) @@ -641,7 +620,7 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv defaultCallbacks dflags + hsc_env <- newHscEnv dflags showIface hsc_env file -- --------------------------------------------------------------------------- @@ -660,7 +639,7 @@ showBanner _postLoadMode dflags = do when (verb >= 2) $ do hPutStr stderr "Glasgow Haskell Compiler, Version " hPutStr stderr cProjectVersion - hPutStr stderr ", for Haskell 98, stage " + hPutStr stderr ", stage " hPutStr stderr cStage hPutStr stderr " booted by GHC version " hPutStrLn stderr cBooterVersion @@ -674,8 +653,8 @@ showInfo dflags = do where flatten (k, String v) = (k, v) flatten (k, FromDynFlags f) = (k, f dflags) -showSupportedLanguages :: IO () -showSupportedLanguages = mapM_ putStrLn supportedLanguages +showSupportedExtensions :: IO () +showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)