+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--
-- 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
" <statement> evaluate/run <statement>\n" ++
" : repeat last command\n" ++
" :{\\n ..lines.. \\n:}\\n multiline command\n" ++
- " :add <filename> ... add module(s) to the current target set\n" ++
+ " :add [*]<module> ... add module(s) to the current target set\n" ++
" :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
" (!: more details; *: all top-level names)\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
" :kind <type> show the kind of <type>\n" ++
- " :load <filename> ... load module(s) and their dependents\n" ++
+ " :load [*]<module> ... load module(s) and their dependents\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :quit exit GHCi\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
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
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
files <- mapM expandPath files
targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
session <- getSession
- io (mapM_ (GHC.addTarget session) targets)
+ -- remove old targets with the same id; e.g. for :add *M
+ io $ mapM_ (GHC.removeTarget session) [ tid | Target tid _ _ <- targets ]
+ io $ mapM_ (GHC.addTarget session) targets
prev_context <- io $ GHC.getContext session
- ok <- io (GHC.load session LoadAllTargets)
+ ok <- io $ GHC.load session LoadAllTargets
afterLoad ok session False prev_context
changeDirectory :: String -> GHCi ()
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
+ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
fromTarget _ = Nothing -- when would we get a module target?
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
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)
[] -> Nothing
(m:_) -> Just m
- summary `matches` Target (TargetModule m) _
+ summary `matches` Target (TargetModule m) _ _
= GHC.ms_mod_name summary == m
- summary `matches` Target (TargetFile f _) _
+ summary `matches` Target (TargetFile f _) _ _
| Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
_ `matches` _
= False
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, warns) <- 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 ()
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)
-- ----------------------------------------------------------------------------
wantInterpretedModule str = do
session <- getSession
modl <- lookupModule str
+ dflags <- getDynFlags
+ when (GHC.modulePackageId modl /= thisPackage dflags) $
+ ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
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; try \':add *" ++ str ++ "' first"))
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)