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
" :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
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
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
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
completeSetOptions w = do
return (filter (w `isPrefixOf`) options)
- where options = "args":"prog":allFlags
+ where options = "args":"prog":flagList
+ flagList = map head $ group $ sort allFlags
completeFilename w = do
ws <- Readline.filenameCompletionFunction w
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 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