X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=8c542c3abc7dbbe607e4954d17a010e3aead604a;hb=7cc35327fd1acde88f3474d4e4727f8d8185ff67;hp=f15c5f423848e72be3856e63695a1c88607f9e6f;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index f15c5f4..8c542c3 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -45,7 +45,7 @@ import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv
-import Var              hiding (setIdType)
+import Var
 import Id
 import IdInfo
 import Name             hiding ( varName )
@@ -90,13 +90,13 @@ import Foreign.StablePtr
 data RunResult
   = RunOk [Name] 		-- ^ names bound by this evaluation
   | RunFailed	 		-- ^ statement failed compilation
-  | RunException Exception	-- ^ statement raised an exception
+  | RunException SomeException	-- ^ statement raised an exception
   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
-   | Complete (Either Exception [HValue])
+   | Complete (Either SomeException [HValue])
           -- ^ the computation completed with either an exception or a value
 
 data Resume
@@ -338,6 +338,7 @@ sandboxIO dflags statusMVar thing =
 -- not "Interrupted", we unset the exception flag before throwing.
 --
 rethrow :: DynFlags -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 609
 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
                    -- If -fbreak-on-error, we break unconditionally,
@@ -355,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e
-
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+                   -- If -fbreak-on-error, we break unconditionally,
+                   --  but with care of not breaking twice 
+                if dopt Opt_BreakOnError dflags &&
+                   not (dopt Opt_BreakOnException dflags)
+                    then poke exceptionFlag 1
+                    else case cast e of
+                         -- If it is an "Interrupted" exception, we allow
+                         --  a possible break by way of -fbreak-on-exception
+                         Just Interrupted -> return ()
+                         -- In any other case, we don't want to break
+                         _ -> poke exceptionFlag 0
+
+                Exception.throwIO se
+#endif
 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do
@@ -512,7 +528,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
    let exn_fs    = fsLit "_exception"
        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
        e_fs      = fsLit "e"
-       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
+       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
                                 vanillaIdInfo
@@ -791,7 +807,7 @@ getContext :: Session -> IO ([Module],[Module])
 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 				return (ic_toplev_scope ic, ic_exports ic))
 
--- | Returns 'True' if the specified module is interpreted, and hence has
+-- | Returns @True@ if the specified module is interpreted, and hence has
 -- its full top-level scope available.
 moduleIsInterpreted :: Session -> Module -> IO Bool
 moduleIsInterpreted s modl = withSession s $ \h ->