X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=f5debfe945096bdcd859a7f42e8d1ba77ead5625;hb=3d73e45b0909b9669d4679cbda29fa2b17b98d2e;hp=7adb0642dc71554f9fd003292a713a75f21c3313;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 7adb064..f5debfe 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) @@ -198,7 +199,7 @@ helpText = " evaluate/run \n" ++ " : repeat last command\n" ++ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ - " :add ... add module(s) to the current target set\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ " :browse[!] [[*]] display the names defined by module \n" ++ " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ @@ -211,7 +212,7 @@ helpText = " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ " :kind show the kind of \n" ++ - " :load ... load module(s) and their dependents\n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ " :main [ ...] run the main function with the given arguments\n" ++ " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ @@ -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 @@ -916,9 +916,11 @@ addModule files = do files <- mapM expandPath files targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession - io (mapM_ (GHC.addTarget session) targets) + -- remove old targets with the same id; e.g. for :add *M + io $ mapM_ (GHC.removeTarget session) [ tid | Target tid _ _ <- targets ] + io $ mapM_ (GHC.addTarget session) targets prev_context <- io $ GHC.getContext session - ok <- io (GHC.load session LoadAllTargets) + ok <- io $ GHC.load session LoadAllTargets afterLoad ok session False prev_context changeDirectory :: String -> GHCi () @@ -981,7 +983,7 @@ chooseEditFile = Just file -> return file Nothing -> ghcError (CmdLineError "No files to edit.") - where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target? defineMacro :: Bool{-overwrite-} -> String -> GHCi () @@ -1054,6 +1056,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) @@ -1140,9 +1143,9 @@ setContextAfterLoad session prev keep_ctxt ms = do [] -> Nothing (m:_) -> Just m - summary `matches` Target (TargetModule m) _ + summary `matches` Target (TargetModule m) _ _ = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ + summary `matches` Target (TargetFile f _) _ _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' _ `matches` _ = False @@ -1503,13 +1506,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 +1824,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 +1843,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 +1862,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 +1870,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) -- ---------------------------------------------------------------------------- @@ -1878,9 +1892,12 @@ wantInterpretedModule :: String -> GHCi Module wantInterpretedModule str = do session <- getSession modl <- lookupModule str + dflags <- getDynFlags + when (GHC.modulePackageId modl /= thisPackage dflags) $ + ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- io (GHC.moduleIsInterpreted session modl) when (not is_interpreted) $ - ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) return modl wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String @@ -1939,7 +1956,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 +2191,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"