X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=38208a0c693efb0b7b1ce38e45fb4983dff3f61e;hb=421b380e75a04f4e1e8e110b46a4bf872e006f79;hp=3d6ce01efde827f300995e33f3531fa52c20dc09;hpb=decbb181cf7a06c6135ca451307a7e7214385f2e;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 3d6ce01..38208a0 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -53,6 +53,7 @@ module GHC (
         parsedSource, coreModule,
         compileToCoreModule, compileToCoreSimplified,
         compileCoreToObj,
+        getModSummary,
 
 	-- * Parsing Haddock comments
 	parseHaddockComment,
@@ -297,9 +298,6 @@ import Data.IORef
 import System.FilePath
 import System.IO
 import System.IO.Error	( try, isDoesNotExistError )
-#if __GLASGOW_HASKELL__ >= 609
-import Data.Typeable (cast)
-#endif
 import Prelude hiding (init)
 
 
@@ -310,51 +308,36 @@ import Prelude hiding (init)
 -- Unless you want to handle exceptions yourself, you should wrap this around
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: DynFlags -> IO a -> IO a
+defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
 defaultErrorHandler dflags inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
-#if __GLASGOW_HASKELL__ < 609
-  handle (\exception -> do
+  ghandle (\exception -> liftIO $ do
            hFlush stdout
-           case exception of
-                -- an IO exception probably isn't our fault, so don't panic
-                IOException _ ->
-                  fatalErrorMsg dflags (text (show exception))
-                AsyncException StackOverflow ->
-                  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
-                ExitException _ -> throw exception
-                _ ->
-                  fatalErrorMsg dflags (text (show (Panic (show exception))))
-           exitWith (ExitFailure 1)
-         ) $
-#else
-  handle (\(SomeException exception) -> do
-           hFlush stdout
-           case cast exception of
+           case fromException exception of
                 -- an IO exception probably isn't our fault, so don't panic
                 Just (ioe :: IOException) ->
                   fatalErrorMsg dflags (text (show ioe))
-                _ -> case cast exception of
+                _ -> case fromException exception of
                      Just StackOverflow ->
                          fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
-                     _ -> case cast exception of
+                     _ -> case fromException exception of
                           Just (ex :: ExitCode) -> throw ex
                           _ ->
                               fatalErrorMsg dflags
                                   (text (show (Panic (show exception))))
            exitWith (ExitFailure 1)
          ) $
-#endif
 
   -- program errors: messages with locations attached.  Sometimes it is
   -- convenient to just throw these as exceptions.
   handleErrMsg
-            (\em -> do printBagOfErrors dflags (unitBag em)
-                       exitWith (ExitFailure 1)) $
+            (\em -> liftIO $ do
+                      printBagOfErrors dflags (unitBag em)
+                      exitWith (ExitFailure 1)) $
 
   -- error messages propagated as exceptions
   handleGhcException
-            (\ge -> do
+            (\ge -> liftIO $ do
   		hFlush stdout
   		case ge of
 		     PhaseFailed _ code -> exitWith code
@@ -1012,19 +995,27 @@ type TypecheckedSource = LHsBinds Id
 --     - default methods are turned into top-level decls.
 --     - dictionary bindings
 
+-- | Return the 'ModSummary' of a module with the given name.
+--
+-- The module must be part of the module graph (see 'hsc_mod_graph' and
+-- 'ModuleGraph').  If this is not the case, this function will throw a
+-- 'GhcApiError'.
+--
+-- This function ignores boot modules and requires that there is only one
+-- non-boot module with the given name.
 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
 getModSummary mod = do
    mg <- liftM hsc_mod_graph getSession
-   case [ ms | ms <- mg, ms_mod_name ms == mod ] of
+   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
      [] -> throw $ mkApiErr (text "Module not part of module graph")
-     (ms:_) -> return ms
+     [ms] -> return ms
+     multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
 
 -- | Parse a module.
 --
 -- Throws a 'SourceError' on parse error.
-parseModule :: GhcMonad m => ModuleName -> m ParsedModule
-parseModule mod = do
-   ms <- getModSummary mod
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
    hsc_env0 <- getSession
    let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
    rdr_module <- parseFile hsc_env ms
@@ -1194,9 +1185,8 @@ compileCore simplify fn = do
      Just modSummary -> do
        -- Now we have the module name;
        -- parse, typecheck and desugar the module
-       let mod = ms_mod_name modSummary
        mod_guts <- coreModule `fmap`
-                      (desugarModule =<< typecheckModule =<< parseModule mod)
+                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
        liftM gutsToCoreModule $
          if simplify
           then do
@@ -2188,7 +2178,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 	    local_opts = getOptions dflags buf src_fn
 	--
 	(dflags', leftovers, warns)
-            <- parseDynamicFlags dflags local_opts
+            <- parseDynamicNoPackageFlags dflags local_opts
         liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
         liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions