Generalise type of 'defaultErrorHandler' so it can be used inside a Ghc session.

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 766ed01..b023885 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -106,7 +106,7 @@ module GHC (
         isModuleInterpreted,
        InteractiveEval.compileExpr, HValue, dynCompileExpr,
        lookupName,
-        GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
         modInfoModBreaks,
         ModBreaks(..), BreakIndex,
         BreakInfo(breakInfo_number, breakInfo_module),
@@ -310,11 +310,11 @@ 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
@@ -328,7 +328,7 @@ defaultErrorHandler dflags inner =
            exitWith (ExitFailure 1)
          ) $
 #else
-  handle (\(SomeException exception) -> do
+  ghandle (\(SomeException exception) -> liftIO $ do
            hFlush stdout
            case cast exception of
                 -- an IO exception probably isn't our fault, so don't panic
@@ -349,12 +349,13 @@ defaultErrorHandler dflags inner =
   -- 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
@@ -2188,7 +2189,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
 
@@ -2555,18 +2556,14 @@ getHistorySpan :: GhcMonad m => History -> m SrcSpan
 getHistorySpan h = withSession $ \hsc_env ->
                           return$ InteractiveEval.getHistorySpan hsc_env h
 
-obtainTerm :: GhcMonad m => Bool -> Id -> m Term
-obtainTerm force id = withSession $ \hsc_env ->
-                        liftIO $ InteractiveEval.obtainTerm hsc_env force id
-
-obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term
-obtainTerm1 force mb_ty a =
+obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a =
     withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
+      liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
 
-obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermB bound force id =
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id =
     withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTermB hsc_env bound force id
+      liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
 
 #endif