X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=42246b204e39977dd52a80e84f79ec9236cdd59d;hb=85981a6fc4bb94af433b0b3655c26c5ec4dda1bd;hp=6722722bebfbc923775e9619992f2f2d6d0f5492;hpb=b8a331a4a5567251c9616d8f9ad609901bfef170;p=ghc-hetmet.git
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 6722722..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
@@ -123,7 +123,8 @@ builtin_commands = [
("check", keepGoing' checkModule, completeHomeModule),
("continue", keepGoing continueCmd, noCompletion),
("cmd", keepGoing cmdCmd, completeExpression),
- ("ctags", keepGoing createCTagsFileCmd, completeFilename),
+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
("def", keepGoing (defineMacro False), completeExpression),
("def!", keepGoing (defineMacro True), completeExpression),
("delete", keepGoing deleteCmd, noCompletion),
@@ -202,7 +203,8 @@ helpText =
" (!: more details; *: all top-level names)\n" ++
" :cd
change directory to \n" ++
" :cmd run the commands returned by ::IO String\n" ++
- " :ctags [] create tags file for Vi (default: \"tags\")\n" ++
+ " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++
+ " (!: use regex instead of line number)\n" ++
" :def define a command :\n" ++
" :edit edit file\n" ++
" :edit edit last module\n" ++
@@ -383,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
@@ -397,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.
@@ -437,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:
-- :
@@ -444,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
@@ -456,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
@@ -572,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
@@ -617,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?
@@ -824,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)
@@ -1147,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
@@ -1723,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
@@ -2075,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 ->
@@ -2087,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)
@@ -2118,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 [ | | ]"
@@ -2166,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