+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--
import SrcLoc
-- Other random utilities
+import ErrUtils
+import CmdLineParser
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic hiding (showException)
--import SystemExts
-import Control.Exception as Exception
+import Exception
-- import Control.Concurrent
import System.FilePath
" :force <expr> print <expr>, forcing unevaluated parts\n" ++
" :forward go forward in the history (after :back)\n" ++
" :history [<n>] after :trace, show the execution history\n" ++
+ " :list show the source code around current breakpoint\n" ++
+ " :list identifier show the source code for <identifier>\n" ++
+ " :list [<module>] <line> show the source code around line number <line>\n" ++
" :print [<name> ...] prints a value without forcing its computation\n" ++
" :sprint [<name> ...] simplifed version of :print\n" ++
" :step single-step after stopping at a breakpoint\n"++
#ifdef USE_EDITLINE
is_tty <- hIsTerminalDevice stdin
- when is_tty $ do
+ when is_tty $ withReadline $ do
Readline.initialize
withGhcAppData
#endif
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
- (Just basePackageId)
+ prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing
GHC.setContext session [] [prel_mod]
default_editor <- findEditor
last_command = Nothing,
cmdqueue = [],
remembered_ctx = [],
- virtual_path = cwd
+ virtual_path = cwd,
+ ghc_e = isJust maybe_exprs
}
#ifdef USE_EDITLINE
-- current progname in the exception text:
-- <progname>: <exception>
io $ withProgName (progname st)
- -- The "fast exit" part just calls exit()
- -- directly instead of doing an orderly
- -- runtime shutdown, otherwise the main
- -- GHCi thread will complain about being
- -- interrupted.
- $ topHandlerFastExit e
+ -- this used to be topHandlerFastExit, see #2228
+ $ topHandler e
runCommands' handle (return Nothing)
-- and finally, exit
interactiveLoop :: Bool -> Bool -> GHCi ()
interactiveLoop is_tty show_prompt =
-- Ignore ^C exceptions caught here
- ghciHandleDyn (\e -> case e of
+ ghciHandleGhcException (\e -> case e of
Interrupted -> do
#if defined(mingw32_HOST_OS)
io (putStrLn "")
return True
#else
checkPerms name =
- Util.handle (\_ -> return False) $ do
+ handleIO (\_ -> return False) $ do
st <- getFileStatus name
me <- getRealUserID
if fileOwner st /= me then do
io yield
saveSession -- for use by completion
prompt <- mkPrompt
- l <- io (readline prompt `finally` setNonBlockingFD 0)
- -- readline sometimes puts stdin into blocking mode,
- -- so we need to put it back for the IO library
+ l <- io $ withReadline (readline prompt)
splatSavedSession
case l of
Nothing -> return Nothing
io (addHistory l)
str <- io $ consoleInputToUnicode True l
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
+ -- 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.
+
+-- These come from the RTS
+foreign import ccall unsafe startTimer :: IO ()
+foreign import ccall unsafe stopTimer :: IO ()
#endif
queryQueue :: GHCi (Maybe String)
runCommands :: GHCi (Maybe String) -> GHCi ()
runCommands = runCommands' handler
-runCommands' :: (Exception -> GHCi Bool) -- Exception handler
+runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
-> GHCi (Maybe String) -> GHCi ()
runCommands' eh getCmd = do
mb_cmd <- noSpace queryQueue
flushInterpBuffers
io installSignalHandlers
b <- isOptionSet RevertCAFs
- io (when b revertCAFs)
+ when b revertCAFs
return (case run_result of GHC.RunOk _ -> True; _ -> False)
help _ = io (putStr helpText)
info :: String -> GHCi ()
-info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s = do { let names = words s
; session <- getSession
; dflags <- getDynFlags
addModule :: [FilePath] -> GHCi ()
addModule files = do
- io (revertCAFs) -- always revert CAFs on load/add.
+ revertCAFs -- always revert CAFs on load/add.
files <- mapM expandPath files
targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
session <- getSession
st <- getGHCiState
let cmd = editor st
when (null cmd)
- $ throwDyn (CmdLineError "editor not set, use :set editor")
+ $ ghcError (CmdLineError "editor not set, use :set editor")
io $ system (cmd ++ ' ':file)
return ()
do targets <- io (GHC.getTargets session)
case msum (map fromTarget targets) of
Just file -> return file
- Nothing -> throwDyn (CmdLineError "No files to edit.")
+ Nothing -> ghcError (CmdLineError "No files to edit.")
where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
fromTarget _ = Nothing -- when would we get a module target?
unlines defined)
else do
if (not overwrite && macro_name `elem` defined)
- then throwDyn (CmdLineError
+ then ghcError (CmdLineError
("macro '" ++ macro_name ++ "' is already defined"))
else do
where undef macro_name = do
cmds <- io (readIORef macros_ref)
if (macro_name `notElem` map cmdName cmds)
- then throwDyn (CmdLineError
+ then ghcError (CmdLineError
("macro '" ++ macro_name ++ "' is not defined"))
else do
io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
prev_context <- io $ GHC.getContext session
-- unload first
+ io $ GHC.abandonAll session
discardActiveBreakPoints
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
afterLoad ok session retain_context prev_context = do
- io (revertCAFs) -- always revert CAFs on load.
+ revertCAFs -- always revert CAFs on load.
discardTickArrays
loaded_mod_summaries <- getLoadedModules session
let loaded_mods = map GHC.ms_mod loaded_mod_summaries
case (as,bs) of
(as@(_:_), _) -> browseModule bang (last as) True
([], bs@(_:_)) -> browseModule bang (last bs) True
- ([], []) -> throwDyn (CmdLineError ":browse: no current module")
- _ -> throwDyn (CmdLineError "syntax: :browse <module>")
+ ([], []) -> ghcError (CmdLineError ":browse: no current module")
+ _ -> ghcError (CmdLineError "syntax: :browse <module>")
-- without bang, show items in context of their parents and omit children
-- with bang, show class methods and data constructors separately, and
mb_mod_info <- io $ GHC.getModuleInfo s modl
case mb_mod_info of
- Nothing -> throwDyn (CmdLineError ("unknown module: " ++
+ Nothing -> ghcError (CmdLineError ("unknown module: " ++
GHC.moduleNameString (GHC.moduleName modl)))
Just mod_info -> do
dflags <- getDynFlags
playCtxtCmd True (cmd, as, bs)
st <- getGHCiState
setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
- | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
(cmd, strs, as, bs) =
case str of
vcat (text "other dynamic, non-language, flag settings:"
:map (flagSetting dflags) nonLanguageDynFlags)
))
- where flagSetting dflags (str,f)
+ where flagSetting dflags (str, f, _)
| dopt f dflags = text " " <> text "-f" <> text str
| otherwise = text " " <> text "-fno-" <> text str
- (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
+ (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
DynFlags.fFlags
- nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
- others
+ nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
+ others
flags = [Opt_PrintExplicitForalls
,Opt_PrintBindResult
,Opt_BreakOnException
newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
- (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
+ (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
+ io $ handleFlagWarnings dflags' warns
if (not (null leftovers))
- then throwDyn (CmdLineError ("unrecognised flags: " ++
- unwords leftovers))
- else return ()
+ then ghcError $ errorsToGhcException leftovers
+ else return ()
new_pkgs <- setDynFlags dflags'
mapM_ unsetOpt plus_opts
let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
- no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
+ no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
no_flags <- mapM no_flag minus_opts
newDynFlags no_flags
["context"] -> showContext
["packages"] -> showPackages
["languages"] -> showLanguages
- _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
+ _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
" | breaks | context | packages | languages ]"))
showModules :: GHCi ()
pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
io $ putStrLn $ showSDoc $ vcat $
text "packages currently loaded:"
- : map (nest 2 . text . packageIdString) pkg_ids
+ : map (nest 2 . text . packageIdString)
+ (sortBy (compare `on` packageIdFS) pkg_ids)
where showFlag (ExposePackage p) = text $ " -package " ++ p
showFlag (HidePackage p) = text $ " -hide-package " ++ p
showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
dflags <- getDynFlags
io $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
- [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
+ [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
(s,r') = span isBreak r
in (n,w):words' isBreak (n+length w+length s) r'
-- In a Haskell expression we want to parse 'a-b' as three words
- -- where a compiler flag (ie. -fno-monomorphism-restriction) should
+ -- where a compiler flag (e.g. -ddump-simpl) should
-- only be a single word.
selectWord [] = (0,w)
selectWord ((offset,x):xs)
-- raising another exception. We therefore don't put the recursive
-- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
+handler :: SomeException -> GHCi Bool
handler exception = do
flushInterpBuffers
io installSignalHandlers
ghciHandle handler (showException exception >> return False)
-showException :: Exception -> GHCi ()
+showException :: SomeException -> GHCi ()
+#if __GLASGOW_HASKELL__ < 609
showException (DynException dyn) =
case fromDynamic dyn of
Nothing -> io (putStrLn ("*** Exception: (unknown)"))
showException other_exception
= io (putStrLn ("*** Exception: " ++ show other_exception))
+#else
+showException (SomeException e) =
+ io $ case cast e 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
-----------------------------------------------------------------------------
-- recursive exception handlers
-- in an exception loop (eg. let a = error a in a) the ^C exception
-- may never be delivered. Thanks to Marcin for pointing out the bug.
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
ghciHandle h (GHCi m) = GHCi $ \s ->
Exception.catch (m s)
(\e -> unGHCi (ghciUnblock (h e)) s)
ghciUnblock :: GHCi a -> GHCi a
ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-ghciTry :: GHCi a -> GHCi (Either Exception a)
+ghciTry :: GHCi a -> GHCi (Either SomeException a)
ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s)
-- ----------------------------------------------------------------------------
modl <- lookupModule str
is_interpreted <- io (GHC.moduleIsInterpreted session modl)
when (not is_interpreted) $
- throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
return modl
wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
Nothing -> stepCmd []
Just _ -> do
Just span <- getCurrentBreakSpan
- let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
+ let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
doContinue f GHC.SingleStep
stepModuleCmd expression = stepCmd expression
| otherwise = breakSyntax
breakSyntax :: a
-breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
do_bold :: Bool
do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
where mTerm = System.Environment.getEnv "TERM"
- `Exception.catch` \_ -> return "TERM not set"
+ `catchIO` \_ -> return "TERM not set"
start_bold :: String
start_bold = "\ESC[1m"
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
--- start_bold/end_bold.
+-- start_bold\/end_bold.
listAround :: SrcSpan -> Bool -> IO ()
listAround span do_highlight = do
contents <- BS.readFile (unpackFS file)
projects / ghc-hetmet.git / blobdiff