X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=48033ae709fad0902acacbe745962e999bdb55bf;hb=fc9bbbab3fe56cf0ff5723abbdb0f496d257f34e;hp=7adb0642dc71554f9fd003292a713a75f21c3313;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 7adb064..48033ae 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -42,6 +42,7 @@ import SrcLoc
 
 -- Other random utilities
 import ErrUtils
+import CmdLineParser
 import Digraph
 import BasicTypes hiding (isTopLevel)
 import Panic      hiding (showException)
@@ -337,8 +338,7 @@ interactiveUI session srcs maybe_exprs = do
 #endif
 
    -- initial context is just the Prelude
-   prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
-                                      (Just basePackageId)
+   prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing
    GHC.setContext session [] [prel_mod]
 
    default_editor <- findEditor
@@ -468,7 +468,7 @@ runGHCi paths maybe_exprs = do
 interactiveLoop :: Bool -> Bool -> GHCi ()
 interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
-  ghciHandleDyn (\e -> case e of 
+  ghciHandleGhcException (\e -> case e of 
 			Interrupted -> do
 #if defined(mingw32_HOST_OS)
 				io (putStrLn "")
@@ -504,7 +504,7 @@ checkPerms _ =
   return True
 #else
 checkPerms name =
-  Util.handle (\_ -> return False) $ do
+  handleIO (\_ -> return False) $ do
      st <- getFileStatus name
      me <- getRealUserID
      if fileOwner st /= me then do
@@ -650,7 +650,7 @@ queryQueue = do
 runCommands :: GHCi (Maybe String) -> GHCi ()
 runCommands = runCommands' handler
 
-runCommands' :: (Exception -> GHCi Bool) -- Exception handler
+runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
              -> GHCi (Maybe String) -> GHCi ()
 runCommands' eh getCmd = do
   mb_cmd <- noSpace queryQueue
@@ -1054,6 +1054,7 @@ loadModule' files = do
   prev_context <- io $ GHC.getContext session
 
   -- unload first
+  io $ GHC.abandonAll session
   discardActiveBreakPoints
   io (GHC.setTargets session [])
   io (GHC.load session LoadAllTargets)
@@ -1503,13 +1504,12 @@ newDynFlags :: [String] -> GHCi ()
 newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
-      (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts
+      (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
       io $ handleFlagWarnings dflags' warns
 
       if (not (null leftovers))
-		then ghcError (CmdLineError ("unrecognised flags: " ++ 
-						unwords leftovers))
-		else return ()
+        then ghcError $ errorsToGhcException leftovers
+        else return ()
 
       new_pkgs <- setDynFlags dflags'
 
@@ -1822,14 +1822,15 @@ completeHomeModuleOrFile=completeNone
 -- raising another exception.  We therefore don't put the recursive
 -- handler arond the flushing operation, so if stderr is closed
 -- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
+handler :: SomeException -> GHCi Bool
 
 handler exception = do
   flushInterpBuffers
   io installSignalHandlers
   ghciHandle handler (showException exception >> return False)
 
-showException :: Exception -> GHCi ()
+showException :: SomeException -> GHCi ()
+#if __GLASGOW_HASKELL__ < 609
 showException (DynException dyn) =
   case fromDynamic dyn of
     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
@@ -1840,6 +1841,17 @@ showException (DynException dyn) =
 
 showException other_exception
   = io (putStrLn ("*** Exception: " ++ show other_exception))
+#else
+showException (SomeException e) =
+  io $ case cast e of
+       Just Interrupted         -> putStrLn "Interrupted."
+       -- omit the location for CmdLineError:
+       Just (CmdLineError s)    -> putStrLn s
+       -- ditto:
+       Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
+       Just other_ghc_ex        -> print other_ghc_ex
+       Nothing                  -> putStrLn ("*** Exception: " ++ show e)
+#endif
 
 -----------------------------------------------------------------------------
 -- recursive exception handlers
@@ -1848,7 +1860,7 @@ showException other_exception
 -- in an exception loop (eg. let a = error a in a) the ^C exception
 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
 ghciHandle h (GHCi m) = GHCi $ \s -> 
    Exception.catch (m s) 
 	(\e -> unGHCi (ghciUnblock (h e)) s)
@@ -1856,7 +1868,7 @@ ghciHandle h (GHCi m) = GHCi $ \s ->
 ghciUnblock :: GHCi a -> GHCi a
 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 
-ghciTry :: GHCi a -> GHCi (Either Exception a)
+ghciTry :: GHCi a -> GHCi (Either SomeException a)
 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) 
 
 -- ----------------------------------------------------------------------------
@@ -1939,7 +1951,7 @@ stepModuleCmd  [] = do
     Nothing  -> stepCmd []
     Just _ -> do
        Just span <- getCurrentBreakSpan
-       let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
+       let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
        doContinue f GHC.SingleStep
 
 stepModuleCmd expression = stepCmd expression
@@ -2174,7 +2186,7 @@ findBreakByCoord mb_file (line, col) arr
 do_bold :: Bool
 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
     where mTerm = System.Environment.getEnv "TERM"
-                  `Exception.catch` \_ -> return "TERM not set"
+                  `catchIO` \_ -> return "TERM not set"
 
 start_bold :: String
 start_bold = "\ESC[1m"