X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=05f61d16ebd0b72284005586a1d262c292ad9210;hb=bb7b45dcf16118fb03bf28aea08a168ac6598a33;hp=1fcae52db6c9efcfde2394dcbee8a70a5208f2f0;hpb=d150f4ec2ded790bb93ce5c6e68e970916f75cbb;p=ghc-hetmet.git
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 1fcae52..05f61d1 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1,7 +1,6 @@
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
-{-# OPTIONS -#include "Linker.h" #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
--
@@ -23,14 +22,14 @@ import Debugger
-- The GHC interface
import qualified GHC hiding (resume, runStmt)
import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
- Module, ModuleName, TyThing(..), Phase,
- BreakIndex, SrcSpan, Resume, SingleStep,
+ TyThing(..), Phase,
+ BreakIndex, Resume, SingleStep,
Ghc, handleSourceError )
import PprTyThing
import DynFlags
import Packages
-import PackageConfig
+-- import PackageConfig
import UniqFM
import HscTypes ( implicitTyThings, handleFlagWarnings )
@@ -39,7 +38,6 @@ import Outputable hiding (printForUser, printForUserPartWay)
import Module -- for ModuleEnv
import Name
import SrcLoc
-import ObjLink
-- Other random utilities
import CmdLineParser
@@ -54,6 +52,7 @@ import NameSet
import Maybes ( orElse, expectJust )
import FastString
import Encoding
+import Foreign.C
#ifndef mingw32_HOST_OS
import System.Posix hiding (getEnv)
@@ -68,7 +67,6 @@ import Control.Monad.Trans
--import SystemExts
import Exception hiding (catch, block, unblock)
-import qualified Exception
-- import Control.Concurrent
@@ -88,7 +86,14 @@ import Control.Monad as Monad
import Text.Printf
import Foreign
import GHC.Exts ( unsafeCoerce# )
+
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
+import GHC.IO.Handle ( hFlushAll )
+#else
import GHC.IOBase ( IOErrorType(InvalidArgument) )
+#endif
+
import GHC.TopHandler
import Data.IORef ( IORef, readIORef, writeIORef )
@@ -118,11 +123,11 @@ 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),
- ("e", keepGoing editFile, completeFilename),
("edit", keepGoing editFile, completeFilename),
("etags", keepGoing createETagsFileCmd, completeFilename),
("force", keepGoing forceCmd, completeExpression),
@@ -198,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" ++
@@ -284,14 +290,16 @@ findEditor = do
return ""
#endif
+foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
+
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
interactiveUI srcs maybe_exprs = do
-- although GHCi compiles with -prof, it is not usable: the byte-code
-- compiler and interpreter don't work with profiling. So we check for
-- this up front and emit a helpful error message (#2197)
- m <- liftIO $ lookupSymbol "PushCostCentre"
- when (isJust m) $
+ i <- liftIO $ isProfiled
+ when (i /= 0) $
ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
-- HACK! If we happen to get into an infinite loop (eg the user
@@ -302,9 +310,9 @@ interactiveUI srcs maybe_exprs = do
-- it refers to might be finalized, including the standard Handles.
-- This sounds like a bug, but we don't have a good solution right
-- now.
- liftIO $ newStablePtr stdin
- liftIO $ newStablePtr stdout
- liftIO $ newStablePtr stderr
+ _ <- liftIO $ newStablePtr stdin
+ _ <- liftIO $ newStablePtr stdout
+ _ <- liftIO $ newStablePtr stderr
-- Initialise buffering for the *interpreted* I/O system
initInterpBuffering
@@ -320,6 +328,12 @@ interactiveUI srcs maybe_exprs = do
-- We don't want the cmd line to buffer any input that might be
-- intended for the program, so unbuffer stdin.
hSetBuffering stdin NoBuffering
+#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
+ -- On Unix, stdin will use the locale encoding. The IO library
+ -- doesn't do this on Windows (yet), so for now we use UTF-8,
+ -- for consistency with GHC 6.10 and to make the tests work.
+ hSetEncoding stdin utf8
+#endif
-- initial context is just the Prelude
prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
@@ -385,7 +399,6 @@ 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
@@ -420,7 +433,7 @@ runGHCi paths maybe_exprs = do
Nothing ->
do
-- enter the interactive loop
- runGHCiInput $ runCommands $ haskelineLoop show_prompt
+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
Just exprs -> do
-- just evaluate the expression we were given
enqueueCommands exprs
@@ -432,7 +445,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
@@ -444,17 +456,16 @@ runGHCiInput f = do
(return Nothing)
let settings = setComplete ghciCompleteWord
$ defaultSettings {historyFile = histFile}
- runInputT settings $ do
- setLogAction
- f
+ runInputT settings f
--- TODO really bad name
-haskelineLoop :: Bool -> InputT GHCi (Maybe String)
-haskelineLoop show_prompt = do
+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
+nextInputLine show_prompt is_tty
+ | is_tty = do
prompt <- if show_prompt then lift mkPrompt else return ""
- l <- getInputLine prompt
- return l
-
+ getInputLine prompt
+ | otherwise = do
+ when show_prompt $ lift mkPrompt >>= liftIO . putStr
+ fileLoop stdin
-- NOTE: We only read .ghci files if they are owned by the current user,
-- and aren't world writable. Otherwise, we could be accidentally
@@ -490,7 +501,7 @@ checkPerms name =
fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
fileLoop hdl = do
- l <- liftIO $ IO.try (BS.hGetLine hdl)
+ l <- liftIO $ IO.try $ hGetLine hdl
case l of
Left e | isEOFError e -> return Nothing
| InvalidArgument <- etype -> return Nothing
@@ -500,7 +511,7 @@ fileLoop hdl = do
-- this can happen if the user closed stdin, or
-- perhaps did getContents which closes stdin at
-- EOF.
- Right l -> fmap Just (Encoding.decode l)
+ Right l -> return (Just l)
mkPrompt :: GHCi String
mkPrompt = do
@@ -610,7 +621,7 @@ runOneCommand eh getCmd = do
-- QUESTION: is userError the one to use here?
collectError = userError "unterminated multiline command :{ .. :}"
doCommand (':' : cmd) = specialCommand cmd
- doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion
+ doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
return False
enqueueCommands :: [String] -> GHCi ()
@@ -624,7 +635,16 @@ runStmt stmt step
| null (filter (not.isSpace) stmt) = return False
| ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
| otherwise
- = do result <- GhciMonad.runStmt stmt step
+ = do
+#if __GLASGOW_HASKELL__ >= 611
+ -- In the new IO library, read handles buffer data even if the Handle
+ -- is set to NoBuffering. This causes problems for GHCi where there
+ -- are really two stdin Handles. So we flush any bufferred data in
+ -- GHCi's stdin Handle here (only relevant if stdin is attached to
+ -- a file, otherwise the read buffer can't be flushed).
+ _ <- liftIO $ IO.try $ hFlushAll stdin
+#endif
+ result <- GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
@@ -730,9 +750,12 @@ lookupCommand str = do
Nothing -> BadCommand
lookupCommand' :: String -> IO (Maybe Command)
-lookupCommand' str = do
+lookupCommand' ":" = return Nothing
+lookupCommand' str' = do
macros <- readIORef macros_ref
- let cmds = builtin_commands ++ macros
+ let{ (str, cmds) = case str' of
+ ':' : rest -> (rest, builtin_commands)
+ _ -> (str', macros ++ builtin_commands) }
-- look for exact match first, then the first prefix match
return $ case [ c | c <- cmds, str == cmdName c ] of
c:_ -> Just c
@@ -856,7 +879,7 @@ changeDirectory dir = do
outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
prev_context <- GHC.getContext
GHC.setTargets []
- GHC.load LoadAllTargets
+ _ <- GHC.load LoadAllTargets
lift $ setContextAfterLoad prev_context False []
GHC.workingDirectoryChanged
dir <- expandPath dir
@@ -875,7 +898,7 @@ editFile str =
let cmd = editor st
when (null cmd)
$ ghcError (CmdLineError "editor not set, use :set editor")
- io $ system (cmd ++ ' ':file)
+ _ <- io $ system (cmd ++ ' ':file)
return ()
-- The user didn't specify a file so we pick one for them.
@@ -911,6 +934,8 @@ chooseEditFile =
fromTarget _ = Nothing -- when would we get a module target?
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro _ (':':_) =
+ io $ putStrLn "macro name cannot start with a colon"
defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
macros <- io (readIORef macros_ref)
@@ -970,17 +995,17 @@ loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
loadModule_ :: [FilePath] -> InputT GHCi ()
-loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
+loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule' files = do
prev_context <- GHC.getContext
-- unload first
- GHC.abandonAll
+ _ <- GHC.abandonAll
lift discardActiveBreakPoints
GHC.setTargets []
- GHC.load LoadAllTargets
+ _ <- GHC.load LoadAllTargets
let (filenames, phases) = unzip files
exp_filenames <- mapM expandPath filenames
@@ -1017,7 +1042,7 @@ checkModule m = do
reloadModule :: String -> InputT GHCi ()
reloadModule m = do
prev_context <- GHC.getContext
- doLoad True prev_context $
+ _ <- doLoad True prev_context $
if null m then LoadAllTargets
else LoadUpTo (GHC.mkModuleName m)
return ()
@@ -1120,13 +1145,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
@@ -1435,7 +1460,7 @@ newDynFlags minus_opts = do
when (packageFlags dflags /= pkg_flags) $ do
io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
GHC.setTargets []
- GHC.load LoadAllTargets
+ _ <- GHC.load LoadAllTargets
io (linkPackages dflags new_pkgs)
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad ([],[]) False []
@@ -1569,6 +1594,7 @@ showPackages = do
where showFlag (ExposePackage p) = text $ " -package " ++ p
showFlag (HidePackage p) = text $ " -hide-package " ++ p
showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
+ showFlag (ExposePackageId p) = text $ " -package-id " ++ p
showLanguages :: GHCi ()
showLanguages = do
@@ -1603,9 +1629,13 @@ ghciCompleteWord line@(left,_) = case firstWord of
Nothing -> return completeFilename
completeCmd = wrapCompleter " " $ \w -> do
- cmds <- liftIO $ readIORef macros_ref
- return (filter (w `isPrefixOf`) (map (':':)
- (map cmdName (builtin_commands ++ cmds))))
+ macros <- liftIO $ readIORef macros_ref
+ let macro_names = map (':':) . map cmdName $ macros
+ let command_names = map (':':) . map cmdName $ builtin_commands
+ let{ candidates = case w of
+ ':' : ':' : _ -> map (':':) command_names
+ _ -> nub $ macro_names ++ command_names }
+ return $ filter (w `isPrefixOf`) candidates
completeMacro = wrapIdentCompleter $ \w -> do
cmds <- liftIO $ readIORef macros_ref
@@ -1779,7 +1809,7 @@ pprintCommand bind force str = do
stepCmd :: String -> GHCi ()
stepCmd [] = doContinue (const True) GHC.SingleStep
-stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+stepCmd expression = runStmt expression GHC.SingleStep >> return ()
stepLocalCmd :: String -> GHCi ()
stepLocalCmd [] = do
@@ -1817,7 +1847,7 @@ enclosingTickSpan mod src = do
traceCmd :: String -> GHCi ()
traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
-traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
+traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
continueCmd :: String -> GHCi ()
continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
@@ -1826,7 +1856,7 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
doContinue pred step = do
runResult <- resume pred step
- afterRunStmt pred runResult
+ _ <- afterRunStmt pred runResult
return ()
abandonCmd :: String -> GHCi ()
@@ -2043,7 +2073,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 ->
@@ -2055,7 +2085,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)
@@ -2086,7 +2116,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 [ | | ]"
@@ -2134,9 +2164,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
@@ -2212,7 +2242,7 @@ lookupModule modName
discardActiveBreakPoints :: GHCi ()
discardActiveBreakPoints = do
st <- getGHCiState
- mapM (turnOffBreak.snd) (breaks st)
+ mapM_ (turnOffBreak.snd) (breaks st)
setGHCiState $ st { breaks = [] }
deleteBreak :: Int -> GHCi ()
@@ -2224,7 +2254,7 @@ deleteBreak identity = do
then printForUser (text "Breakpoint" <+> ppr identity <+>
text "does not exist")
else do
- mapM (turnOffBreak.snd) this
+ mapM_ (turnOffBreak.snd) this
setGHCiState $ st { breaks = rest }
turnOffBreak :: BreakLocation -> GHCi Bool