X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=9c993345bb7fa093f2722e668466f637359a298d;hb=fd26d0ac1b48890dc7c3b5b60b42373fa964cdc8;hp=a62663d033c68c94311c6a3cec7c788ac86d6637;hpb=1971591f865ac0806802c476f23792ae2c89411a;p=ghc-hetmet.git

diff --git a/ghc/Main.hs b/ghc/Main.hs
index a62663d..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 )
@@ -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
@@ -497,24 +496,15 @@ 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 showSupportedExtensionsMode))
-         Supported
   , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
-         Supported
   ] ++
   [ Flag k'                     (PassFlag (setMode mode))
-         Supported
   | (k, v) <- compilerInfo,
     let k' = "-print-" ++ map (replaceSpace . toLower) k
         replaceSpace ' ' = '-'
@@ -526,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
@@ -595,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"
@@ -611,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
 
@@ -620,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)
 
@@ -643,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
 
 -- ---------------------------------------------------------------------------
@@ -662,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
@@ -677,7 +654,7 @@ showInfo dflags = do
           flatten (k, FromDynFlags f) = (k, f dflags)
 
 showSupportedExtensions :: IO ()
-showSupportedExtensions = mapM_ putStrLn supportedExtensions
+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
 
 showVersion :: IO ()
 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)