X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=42246b204e39977dd52a80e84f79ec9236cdd59d;hb=8c33abc68ed4d386b7e986bdba08d055abf9ccc5;hp=a5a1ba480a7d841165f8e75bd88aab932520961a;hpb=b78303a8d1b21a562b344fd0c4754969948d2419;p=ghc-hetmet.git diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index a5a1ba4..42246b2 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -32,7 +32,7 @@ import Packages -- import PackageConfig import UniqFM -import HscTypes ( implicitTyThings, handleFlagWarnings ) +import HscTypes ( handleFlagWarnings ) import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv @@ -385,6 +385,10 @@ runGHCi paths maybe_exprs = do Right home -> return (Just (home ".ghci")) _ -> return Nothing + canonicalizePath' :: FilePath -> IO (Maybe FilePath) + canonicalizePath' fp = liftM Just (canonicalizePath fp) + `catchIO` \_ -> return Nothing + sourceConfigFile :: FilePath -> GHCi () sourceConfigFile file = do exists <- io $ doesFileExist file @@ -399,15 +403,14 @@ runGHCi paths maybe_exprs = do -- can we assume this will always be the case? -- This would be a good place for runFileInputT. Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do - setLogAction runCommands $ fileLoop hdl where getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do - cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] - cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0) - mapM_ sourceConfigFile (nub cfgs) + mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0) + mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the -- CWD is $HOME. @@ -439,6 +442,8 @@ runGHCi paths maybe_exprs = do -- just evaluate the expression we were given enqueueCommands exprs let handle e = do st <- getGHCiState + -- flush the interpreter's stdout/stderr on exit (#3890) + flushInterpBuffers -- Jump through some hoops to get the -- current progname in the exception text: -- : @@ -446,7 +451,6 @@ runGHCi paths maybe_exprs = do -- this used to be topHandlerFastExit, see #2228 $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - setLogAction runCommands' handle (return Nothing) -- and finally, exit @@ -458,9 +462,7 @@ runGHCiInput f = do (return Nothing) let settings = setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile} - runInputT settings $ do - setLogAction - f + runInputT settings f nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) nextInputLine show_prompt is_tty @@ -574,9 +576,14 @@ runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands' eh getCmd = do - b <- handleGhcException (\e -> case e of - Interrupted -> return False - _other -> liftIO (print e) >> return True) + b <- ghandle (\e -> case fromException e of + Just UserInterrupt -> return False + _ -> case fromException e of + Just ghc_e -> + do liftIO (print (ghc_e :: GhcException)) + return True + _other -> + liftIO (Exception.throwIO e)) (runOneCommand eh getCmd) if b then return () else runCommands' eh getCmd @@ -619,7 +626,7 @@ runOneCommand eh getCmd = do maybe (liftIO (ioError collectError)) (\l->if removeSpaces l == ":}" then return (Just $ removeSpaces c) - else collectCommand q (c++map normSpace l)) + else collectCommand q (c ++ "\n" ++ map normSpace l)) where normSpace '\r' = ' ' normSpace c = c -- QUESTION: is userError the one to use here? @@ -826,9 +833,12 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ do -- constructor in the same type filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + = filterOut has_parent xs where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + all_names = mkNameSet (map (getName . get_thing) xs) + has_parent x = case pprTyThingParent_maybe (get_thing x) of + Just p -> getName p `elemNameSet` all_names + Nothing -> False pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) @@ -1149,13 +1159,13 @@ typeOfExpr str ty <- GHC.exprType str dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] + printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] kindOfType :: String -> InputT GHCi () kindOfType str = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do ty <- GHC.typeKind str - printForUser' $ text str <+> dcolon <+> ppr ty + printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> InputT GHCi Bool quit _ = return True @@ -1725,13 +1735,15 @@ handler exception = do showException :: SomeException -> GHCi () showException se = io $ case fromException se 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 se) + Nothing -> + case fromException se of + Just UserInterrupt -> putStrLn "Interrupted." + _other -> putStrLn ("*** Exception: " ++ show se) ----------------------------------------------------------------------------- -- recursive exception handlers @@ -2077,7 +2089,7 @@ listCmd "" = do mb_span <- lift getCurrentBreakSpan case mb_span of Nothing -> - printForUser' $ text "Not stopped at a breakpoint; nothing to list" + printForUser $ text "Not stopped at a breakpoint; nothing to list" Just span | GHC.isGoodSrcSpan span -> listAround span True | otherwise -> @@ -2089,7 +2101,7 @@ listCmd "" = do [] -> text "rerunning with :trace," _ -> empty doWhat = traceIt <+> text ":back then :list" - printForUser' (text "Unable to list source for" <+> + printForUser (text "Unable to list source for" <+> ppr span $$ text "Try" <+> doWhat) listCmd str = list2 (words str) @@ -2120,7 +2132,7 @@ list2 [arg] = do noCanDo name $ text "can't find its location: " <> ppr loc where - noCanDo n why = printForUser' $ + noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why list2 _other = outputStrLn "syntax: :list [ | | ]" @@ -2168,9 +2180,9 @@ listAround span do_highlight = do where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span - col1 = GHC.srcSpanStartCol span + col1 = GHC.srcSpanStartCol span - 1 line2 = GHC.srcSpanEndLine span - col2 = GHC.srcSpanEndCol span + col2 = GHC.srcSpanEndCol span - 1 pad_before | line1 == 1 = 0 | otherwise = 1