import UniqFM
#endif
-import HscTypes ( implicitTyThings, reflectGhc, reifyGhc )
+import HscTypes ( implicitTyThings, reflectGhc, reifyGhc
+ , handleFlagWarnings )
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import Outputable hiding (printForUser, printForUserPartWay)
import Module -- for ModuleEnv
import SrcLoc
-- Other random utilities
-import ErrUtils
import CmdLineParser
import Digraph
import BasicTypes hiding (isTopLevel)
import Linker
import Util
import NameSet
-import Maybes ( orElse )
+import Maybes ( orElse, expectJust )
import FastString
import Encoding
import MonadUtils ( liftIO )
import System.IO
import System.IO.Error as IO
import Data.Char
-import Data.Dynamic
import Data.Array
import Control.Monad as Monad
import Text.Printf
import Data.IORef ( IORef, readIORef, writeIORef )
-#ifdef USE_EDITLINE
-import System.Posix.Internals ( setNonBlockingFD )
-#endif
-
-----------------------------------------------------------------------------
ghciWelcomeMsg :: String
("reload", keepGoing reloadModule, Nothing, completeNone),
("run", keepGoing runRun, Nothing, completeIdentifier),
("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
- ("show", keepGoing showCmd, Nothing, completeNone),
+ ("show", keepGoing showCmd, Nothing, completeShowOptions),
("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
("step", keepGoing stepCmd, Nothing, completeIdentifier),
("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
" :set editor <cmd> set the command used for :edit\n" ++
- " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
+ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
" :unset <option> ... unset options\n" ++
"\n" ++
" Options for ':set' and ':unset':\n" ++
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
-interactiveUI srcs maybe_exprs = do
+interactiveUI srcs maybe_exprs = withTerminalReset $ do
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
default_editor <- liftIO $ findEditor
- cwd <- liftIO $ getCurrentDirectory
-
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = "<interactive>",
args = [],
last_command = Nothing,
cmdqueue = [],
remembered_ctx = [],
- virtual_path = cwd,
ghc_e = isJust maybe_exprs
}
Right dir -> right dir
_ -> left
+-- libedit doesn't always restore the terminal settings correctly (as of at
+-- least 07/12/2008); see trac #2691. Work around this by manually resetting
+-- the terminal outselves.
+withTerminalReset :: Ghc () -> Ghc ()
+#ifdef mingw32_HOST_OS
+withTerminalReset = id
+#else
+withTerminalReset f = do
+ isTTY <- liftIO $ hIsTerminalDevice stdout
+ if not isTTY
+ then f
+ else gbracket (liftIO $ getTerminalAttributes stdOutput)
+ (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately)
+ (const f)
+#endif
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
return (Just str)
withReadline :: IO a -> IO a
-withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0)
- -- Two problems are being worked around here:
- -- 1. readline sometimes puts stdin into blocking mode,
- -- so we need to put it back for the IO library
- -- 2. editline doesn't handle some of its system calls returning
+withReadline = bracket_ stopTimer startTimer
+ -- editline doesn't handle some of its system calls returning
-- EINTR, so our timer signal confuses it, hence we turn off
-- the timer signal when making calls to editline. (#2277)
-- If editline is ever fixed, we can remove this.
where
printErrorAndKeepGoing err = do
GHC.printExceptionAndWarnings err
- return True
+ return False
noSpace q = q >>= maybe (return Nothing)
(\c->case removeSpaces c of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
- GHC.RunBreak _ names mb_info
- | isNothing mb_info ||
+ GHC.RunBreak _ names mb_info
+ | isNothing mb_info ||
step_here (GHC.resumeSpan $ head resumes) -> do
- printForUser $ ptext (sLit "Stopped at") <+>
- ppr (GHC.resumeSpan $ head resumes)
--- printTypeOfNames session names
- let namesSorted = sortBy compareNames names
- tythings <- catMaybes `liftM`
- mapM GHC.lookupName namesSorted
- docs <- pprTypeAndContents [id | AnId id <- tythings]
- printForUserPartWay docs
- maybe (return ()) runBreakCmd mb_info
+ mb_id_loc <- toBreakIdAndLocation mb_info
+ let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+ if (null breakCmd)
+ then printStoppedAtBreakInfo (head resumes) names
+ else enqueueCommands [breakCmd]
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
return ()
- | otherwise -> resume GHC.SingleStep >>=
+ | otherwise -> resume step_here GHC.SingleStep >>=
afterRunStmt step_here >> return ()
_ -> return ()
return (case run_result of GHC.RunOk _ -> True; _ -> False)
-runBreakCmd :: GHC.BreakInfo -> GHCi ()
-runBreakCmd info = do
+toBreakIdAndLocation ::
+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
+toBreakIdAndLocation Nothing = return Nothing
+toBreakIdAndLocation (Just info) = do
let mod = GHC.breakInfo_module info
nm = GHC.breakInfo_number info
st <- getGHCiState
- case [ loc | (_,loc) <- breaks st,
- breakModule loc == mod, breakTick loc == nm ] of
- [] -> return ()
- loc:_ | null cmd -> return ()
- | otherwise -> do enqueueCommands [cmd]; return ()
- where cmd = onBreakCmd loc
+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+ breakModule loc == mod,
+ breakTick loc == nm ]
+
+printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
+printStoppedAtBreakInfo resume names = do
+ printForUser $ ptext (sLit "Stopped at") <+>
+ ppr (GHC.resumeSpan resume)
+ -- printTypeOfNames session names
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
+ docs <- pprTypeAndContents [id | AnId id <- tythings]
+ printForUserPartWay docs
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames names
info :: String -> GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = do { let names = words s
+info s = handleSourceError GHC.printExceptionAndWarnings $ do
+ { let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
; mapM_ (infoThing pefas) names }
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
str <- io ((unsafeCoerce# fun :: String -> IO String) s)
+ -- make sure we force any exceptions in the result, while we are still
+ -- inside the exception handler for commands:
+ seqList str (return ())
enqueueCommands (lines str)
return False
let modl = GHC.mkModuleName m
prev_context <- GHC.getContext
ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
- r <- GHC.typecheckModule =<< GHC.parseModule modl
+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
io $ putStrLn (showSDoc (
case GHC.moduleInfo r of
cm | Just scope <- GHC.modInfoTopLevelScope cm ->
let
- (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
+ (local,global) = ASSERT( all isExternalName scope )
+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
in
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
ty <- GHC.exprType str
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
- printForUser $ text str <+> dcolon
- <+> pprTypeForUser pefas ty
+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
kindOfType :: String -> GHCi ()
kindOfType str
-- We would like to improve this; see #1799.
sorted_names = loc_sort local ++ occ_sort external
where
- (local,external) = partition ((==modl) . nameModule) names
+ (local,external) = ASSERT( all isExternalName names )
+ partition ((==modl) . nameModule) names
occ_sort = sortBy (compare `on` nameOccName)
-- try to sort by src location. If the first name in
-- our list has a good source location, then they all should.
st <- getGHCiState
if null value
then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
- else setGHCiState st{ prompt = remQuotes value }
- where
- remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
- remQuotes x = x
+ else case value of
+ '\"' : _ -> case reads value of
+ [(value', xs)] | all isSpace xs ->
+ setGHCiState (st { prompt = value' })
+ _ ->
+ io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
+ _ -> setGHCiState (st { prompt = value })
setOptions wds =
do -- first, deal with the GHCi opts (+s, +t, etc.)
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
(dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
- io $ handleFlagWarnings dflags' warns
+ handleFlagWarnings dflags' warns
if (not (null leftovers))
then ghcError $ errorsToGhcException leftovers
completeNone _w = return []
completeMacro, completeIdentifier, completeModule,
- completeHomeModule, completeSetOptions, completeFilename,
- completeHomeModuleOrFile
+ completeHomeModule, completeSetOptions, completeShowOptions,
+ completeFilename, completeHomeModuleOrFile
:: String -> IO [String]
#ifdef USE_EDITLINE
completeSetOptions w = do
return (filter (w `isPrefixOf`) options)
- where options = "args":"prog":allFlags
+ where options = "args":"prog":"prompt":"editor":"stop":flagList
+ flagList = map head $ group $ sort allFlags
+
+completeShowOptions w = do
+ return (filter (w `isPrefixOf`) options)
+ where options = ["args", "prog", "prompt", "editor", "stop",
+ "modules", "bindings", "linker", "breaks",
+ "context", "packages", "languages"]
completeFilename w = do
ws <- Readline.filenameCompletionFunction w
where
pkg_db = pkgIdMap (pkgState dflags)
#else
-completeMacro = completeNone
-completeIdentifier = completeNone
-completeModule = completeNone
-completeHomeModule = completeNone
-completeSetOptions = completeNone
-completeFilename = completeNone
+completeMacro = completeNone
+completeIdentifier = completeNone
+completeModule = completeNone
+completeHomeModule = completeNone
+completeSetOptions = completeNone
+completeShowOptions = completeNone
+completeFilename = completeNone
completeHomeModuleOrFile=completeNone
#endif
ghciHandle handler (showException exception >> return False)
showException :: SomeException -> GHCi ()
-#if __GLASGOW_HASKELL__ < 609
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-#else
-showException (SomeException e) =
- io $ case cast e of
+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 e)
-#endif
+ Nothing -> putStrLn ("*** Exception: " ++ show se)
-----------------------------------------------------------------------------
-- recursive exception handlers
case names of
[] -> return ()
(n:_) -> do
- let modl = GHC.nameModule n
+ let modl = ASSERT( isExternalName n ) GHC.nameModule n
if not (GHC.isExternalName n)
then noCanDo n $ ppr n <>
text " is not defined in an interpreted module"
-- doContinue :: SingleStep -> GHCi ()
doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
doContinue pred step = do
- runResult <- resume step
+ runResult <- resume pred step
afterRunStmt pred runResult
return ()
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
- then findBreakAndSet (GHC.nameModule name) $
+ then ASSERT( isExternalName name )
+ findBreakAndSet (GHC.nameModule name) $
findBreakByCoord (Just (GHC.srcLocFile loc))
(GHC.srcLocLine loc,
GHC.srcLocCol loc)
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then do
- tickArray <- getTickArray (GHC.nameModule name)
+ tickArray <- ASSERT( isExternalName name )
+ getTickArray (GHC.nameModule name)
let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
(GHC.srcLocLine loc, GHC.srcLocCol loc)
tickArray
case this of
[] -> panic "listModuleLine"
summ:_ -> do
- let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
io $ listAround (GHC.srcLocSpan loc) False
projects / ghc-hetmet.git / blobdiff