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
findEditor :: IO String
findEditor = do
getEnv "EDITOR"
- `IO.catch` \_ -> do
+ `catchIO` \_ -> do
#if mingw32_HOST_OS
win <- System.Win32.getWindowsDirectory
return (win </> "notepad.exe")
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
+default_progname, default_prompt, default_stop :: String
+default_progname = "<interactive>"
+default_prompt = "%s> "
+default_stop = ""
+
+default_args :: [String]
+default_args = []
+
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
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
+#if defined(mingw32_HOST_OS)
-- 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.
default_editor <- liftIO $ findEditor
startGHCi (runGHCi srcs maybe_exprs)
- GHCiState{ progname = "<interactive>",
- args = [],
- prompt = "%s> ",
- stop = "",
+ GHCiState{ progname = default_progname,
+ args = default_args,
+ prompt = default_prompt,
+ stop = default_stop,
editor = default_editor,
-- session = session,
options = [],
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
- either_dir <- IO.try (getAppUserDataDirectory "ghc")
- case either_dir of
- Right dir -> right dir
- _ -> left
+ either_dir <- IO.try (getAppUserDataDirectory "ghc")
+ case either_dir of
+ Right dir ->
+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
+ right dir
+ _ -> left
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
- let
+ let
read_dot_files = not opt_IgnoreDotGhci
current_dir = return (Just ".ghci")
- app_user_dir = io $ withGhcAppData
+ app_user_dir = liftIO $ withGhcAppData
(\dir -> return (Just (dir </> "ghci.conf")))
(return Nothing)
home_dir = do
- either_dir <- io $ IO.try (getEnv "HOME")
+ either_dir <- liftIO $ IO.try (getEnv "HOME")
case either_dir of
Right home -> return (Just (home </> ".ghci"))
_ -> return Nothing
sourceConfigFile :: FilePath -> GHCi ()
sourceConfigFile file = do
- exists <- io $ doesFileExist file
+ exists <- liftIO $ doesFileExist file
when exists $ do
- dir_ok <- io $ checkPerms (getDirectory file)
- file_ok <- io $ checkPerms file
+ dir_ok <- liftIO $ checkPerms (getDirectory file)
+ file_ok <- liftIO $ checkPerms file
when (dir_ok && file_ok) $ do
- either_hdl <- io $ IO.try (openFile file ReadMode)
+ either_hdl <- liftIO $ IO.try (openFile file ReadMode)
case either_hdl of
Left _e -> return ()
-- NOTE: this assumes that runInputT won't affect the terminal;
-- can we assume this will always be the case?
-- This would be a good place for runFileInputT.
- Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
+ Right hdl ->
+ do runInputTWithPrefs defaultPrefs defaultSettings $
runCommands $ fileLoop hdl
+ liftIO (hClose hdl `catchIO` \_ -> return ())
where
getDirectory f = case takeDirectory f of "" -> "."; d -> d
when (read_dot_files) $ do
mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
- mcfgs <- io $ mapM canonicalizePath' (catMaybes mcfgs0)
+ mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
-- nub, because we don't want to read .ghci twice if the
-- CWD is $HOME.
filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
loadModule (zip filePaths' phases)
when (isJust maybe_exprs && failed ok) $
- io (exitWith (ExitFailure 1))
+ liftIO (exitWith (ExitFailure 1))
-- if verbosity is greater than 0, or we are connected to a
-- terminal, display the prompt in the interactive loop.
- is_tty <- io (hIsTerminalDevice stdin)
+ is_tty <- liftIO (hIsTerminalDevice stdin)
dflags <- getDynFlags
let show_prompt = verbosity dflags > 0 || is_tty
-- Jump through some hoops to get the
-- current progname in the exception text:
-- <progname>: <exception>
- io $ withProgName (progname st)
+ liftIO $ withProgName (progname st)
-- this used to be topHandlerFastExit, see #2228
- $ topHandler e
+ $ topHandler e
runInputTWithPrefs defaultPrefs defaultSettings $ do
runCommands' handle (return Nothing)
-- and finally, exit
- io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
- histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
- (return Nothing)
+ histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
+ (return Nothing)
let settings = setComplete ghciCompleteWord
$ defaultSettings {historyFile = histFile}
runInputT settings f
(doCommand c)
where
printErrorAndKeepGoing err = do
- GHC.printExceptionAndWarnings err
+ GHC.printException err
return False
noSpace q = q >>= maybe (return Nothing)
| "import " `isPrefixOf` stmt
= do newContextCmd (Import stmt); return False
| otherwise
- = do
-#if __GLASGOW_HASKELL__ >= 611
- -- In the new IO library, read handles buffer data even if the Handle
+ = do -- 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 <- withFlattenedDynflags $ GhciMonad.runStmt stmt step
+ result <- GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
_ -> return ()
flushInterpBuffers
- io installSignalHandlers
+ liftIO installSignalHandlers
b <- isOptionSet RevertCAFs
when b revertCAFs
Just c -> return $ GotCommand c
Nothing -> return NoLastCommand
lookupCommand str = do
- mc <- io $ lookupCommand' str
+ mc <- liftIO $ lookupCommand' str
st <- getGHCiState
setGHCiState st{ last_command = mc }
return $ case mc of
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
-noArgs _ _ = io $ putStrLn "This command takes no arguments"
+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
help :: String -> GHCi ()
-help _ = io (putStr helpText)
+help _ = liftIO (putStr helpText)
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = handleSourceError GHC.printExceptionAndWarnings $
- withFlattenedDynflags $ do
- { let names = words s
+info s = handleSourceError GHC.printException $
+ do { let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
; mapM_ (infoThing pefas) names }
runMain :: String -> GHCi ()
runMain s = case toArgs s of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right args ->
- withFlattenedDynflags $ do
- dflags <- getDynFlags
+ do dflags <- getDynFlags
case mainFunIs dflags of
Nothing -> doWithArgs args "main"
Just f -> doWithArgs args f
runRun :: String -> GHCi ()
runRun s = case toCmdArgs s of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right (cmd, args) -> doWithArgs args cmd
doWithArgs :: [String] -> String -> GHCi ()
changeDirectory dir = do
graph <- GHC.getModuleGraph
when (not (null graph)) $
- do liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,"
- liftIO $ putStrLn "because the search path has changed."
+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
prev_context <- GHC.getContext
GHC.setTargets []
_ <- GHC.load LoadAllTargets
trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
trySuccess act =
- handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+ handleSourceError (\e -> do GHC.printException e
return Failed) $ do
act
let cmd = editor st
when (null cmd)
$ ghcError (CmdLineError "editor not set, use :set editor")
- _ <- io $ system (cmd ++ ' ':file)
+ _ <- liftIO $ system (cmd ++ ' ':file)
return ()
-- The user didn't specify a file so we pick one for them.
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro _ (':':_) =
- io $ putStrLn "macro name cannot start with a colon"
+ liftIO $ putStrLn "macro name cannot start with a colon"
defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
- macros <- io (readIORef macros_ref)
+ macros <- liftIO (readIORef macros_ref)
let defined = map cmdName macros
if (null macro_name)
then if null defined
- then io $ putStrLn "no macros defined"
- else io $ putStr ("the following macros are defined:\n" ++
- unlines defined)
+ then liftIO $ putStrLn "no macros defined"
+ else liftIO $ putStr ("the following macros are defined:\n" ++
+ unlines defined)
else do
if (not overwrite && macro_name `elem` defined)
then ghcError (CmdLineError
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
- withFlattenedDynflags $ do
+ handleSourceError (\e -> GHC.printException e) $
+ do
hv <- GHC.compileExpr new_expr
- io (writeIORef macros_ref --
- (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
+ liftIO (writeIORef macros_ref --
+ (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
- str <- io ((unsafeCoerce# fun :: String -> IO String) s)
+ str <- liftIO ((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 ())
undefineMacro :: String -> GHCi ()
undefineMacro str = mapM_ undef (words str)
where undef macro_name = do
- cmds <- io (readIORef macros_ref)
+ cmds <- liftIO (readIORef macros_ref)
if (macro_name `notElem` map cmdName cmds)
then ghcError (CmdLineError
("macro '" ++ macro_name ++ "' is not defined"))
else do
- io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
+ liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
- withFlattenedDynflags $ do
+ handleSourceError (\e -> GHC.printException e) $
+ do
hv <- GHC.compileExpr expr
- cmds <- io $ (unsafeCoerce# hv :: IO String)
+ cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
return ()
checkModule m = do
let modl = GHC.mkModuleName m
prev_context <- GHC.getContext
- ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
liftIO $ putStrLn $ showSDoc $
case GHC.moduleInfo r of
loaded_mod_names = map GHC.moduleName loaded_mods
modulesLoadedMsg ok loaded_mod_names
- withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
+ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
- $ withFlattenedDynflags
+ = handleSourceError GHC.printException
$ do
ty <- GHC.exprType str
dflags <- getDynFlags
kindOfType :: String -> InputT GHCi ()
kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
- $ withFlattenedDynflags
+ = handleSourceError GHC.printException
$ do
ty <- GHC.typeKind str
printForUser $ text str <+> dcolon <+> ppr ty
quit _ = return True
shellEscape :: String -> GHCi Bool
-shellEscape str = io (system str >> return False)
-
-withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
-withFlattenedDynflags m
- = do dflags <- GHC.getSessionDynFlags
- gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags))
- (\_ -> GHC.setSessionDynFlags dflags)
- (\_ -> m)
+shellEscape str = liftIO (system str >> return False)
-----------------------------------------------------------------------------
-- Browsing a module's contents
-- indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
-browseModule bang modl exports_only = withFlattenedDynflags $ do
+browseModule bang modl exports_only = do
-- :browse! reports qualifiers wrt current context
current_unqual <- GHC.getPrintUnqual
-- Temporarily set the context to the module we're interested in,
playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
playCtxtCmd fail cmd = do
- withFlattenedDynflags $ do
(prev_as,prev_bs) <- GHC.getContext
case cmd of
SetContext as bs -> do
setCmd ""
= do st <- getGHCiState
let opts = options st
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
text "options currently set: " <>
if null opts
then text "none."
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
dflags <- getDynFlags
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
vcat (text "GHCi-specific dynamic flag settings:"
:map (flagSetting dflags) ghciFlags)
))
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
vcat (text "other dynamic, non-language, flag settings:"
:map (flagSetting dflags) others)
))
= case getCmd str of
Right ("args", rest) ->
case toArgs rest of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right args -> setArgs args
Right ("prog", rest) ->
case toArgs rest of
Right [prog] -> setProg prog
- _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
Right ("stop", rest) -> setStop $ dropWhile isSpace rest
_ -> case toArgs str of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right wds -> setOptions wds
setArgs, setOptions :: [String] -> GHCi ()
setPrompt value = do
st <- getGHCiState
if null value
- then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
+ then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
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."
+ liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
_ -> setGHCiState (st { prompt = value })
setOptions wds =
newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
- (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
- handleFlagWarnings dflags' warns
+ (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
+ liftIO $ handleFlagWarnings dflags' warns
if (not (null leftovers))
then ghcError $ errorsToGhcException leftovers
-- and link the new packages.
dflags <- getDynFlags
when (packageFlags dflags /= pkg_flags) $ do
- io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
+ liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
GHC.setTargets []
_ <- GHC.load LoadAllTargets
- io (linkPackages dflags new_pkgs)
+ liftIO (linkPackages dflags new_pkgs)
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad ([],[]) False []
return ()
unsetOptions :: String -> GHCi ()
unsetOptions str
- = do -- first, deal with the GHCi opts (+s, +t, etc.)
- let opts = words str
- (minus_opts, rest1) = partition isMinus opts
- (plus_opts, rest2) = partitionWith isPlus rest1
-
- if (not (null rest2))
- then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
- else do
+ = -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partitionWith isPlus rest1
+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
+
+ defaulters =
+ [ ("args" , setArgs default_args)
+ , ("prog" , setProg default_progname)
+ , ("prompt", setPrompt default_prompt)
+ , ("editor", liftIO findEditor >>= setEditor)
+ , ("stop" , setStop default_stop)
+ ]
+
+ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+ no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
+
+ in if (not (null rest3))
+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
+ else do
+ mapM_ (fromJust.flip lookup defaulters) other_opts
- mapM_ unsetOpt plus_opts
-
- let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
- no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
+ mapM_ unsetOpt plus_opts
- no_flags <- mapM no_flag minus_opts
- newDynFlags no_flags
+ no_flags <- mapM no_flag minus_opts
+ newDynFlags no_flags
isMinus :: String -> Bool
isMinus ('-':_) = True
setOpt str
= case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> setOption o
unsetOpt str
= case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> unsetOption o
strToGHCiOpt :: String -> (Maybe GHCiOption)
-- code for `:show'
showCmd :: String -> GHCi ()
-showCmd str = withFlattenedDynflags $ do
+showCmd str = do
st <- getGHCiState
case words str of
- ["args"] -> io $ putStrLn (show (args st))
- ["prog"] -> io $ putStrLn (show (progname st))
- ["prompt"] -> io $ putStrLn (show (prompt st))
- ["editor"] -> io $ putStrLn (show (editor st))
- ["stop"] -> io $ putStrLn (show (stop st))
+ ["args"] -> liftIO $ putStrLn (show (args st))
+ ["prog"] -> liftIO $ putStrLn (show (progname st))
+ ["prompt"] -> liftIO $ putStrLn (show (prompt st))
+ ["editor"] -> liftIO $ putStrLn (show (editor st))
+ ["stop"] -> liftIO $ putStrLn (show (stop st))
["modules" ] -> showModules
["bindings"] -> showBindings
- ["linker"] -> io showLinkerState
+ ["linker"] -> liftIO showLinkerState
["breaks"] -> showBkptTable
["context"] -> showContext
["packages"] -> showPackages
showModules = do
loaded_mods <- getLoadedModules
-- we want *loaded* modules only, see #1734
- let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
mapM_ show_one loaded_mods
getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
showPackages :: GHCi ()
showPackages = do
pkg_flags <- fmap packageFlags getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
+ liftIO $ putStrLn $ showSDoc $ vcat $
text ("active package flags:"++if null pkg_flags then " none" else "")
: map showFlag pkg_flags
where showFlag (ExposePackage p) = text $ " -package " ++ p
showLanguages :: GHCi ()
showLanguages = do
dflags <- getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
+ liftIO $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
[text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
handler exception = do
flushInterpBuffers
- io installSignalHandlers
+ liftIO installSignalHandlers
ghciHandle handler (showException exception >> return False)
showException :: SomeException -> GHCi ()
showException se =
- io $ case fromException se of
- -- 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 ->
- case fromException se of
- Just UserInterrupt -> putStrLn "Interrupted."
- _other -> putStrLn ("*** Exception: " ++ show se)
+ liftIO $ case fromException se of
+ -- 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 ->
+ case fromException se of
+ Just UserInterrupt -> putStrLn "Interrupted."
+ _ -> putStrLn ("*** Exception: " ++ show se)
-----------------------------------------------------------------------------
-- recursive exception handlers
-> (Name -> m ())
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
- handleSourceError (GHC.printExceptionAndWarnings) $ do
+ handleSourceError GHC.printException $ do
names <- GHC.parseName str
case names of
[] -> return ()
pprintCommand :: Bool -> Bool -> String -> GHCi ()
pprintCommand bind force str = do
- withFlattenedDynflags $ pprintClosureCommand bind force str
+ pprintClosureCommand bind force str
stepCmd :: String -> GHCi ()
stepCmd [] = doContinue (const True) GHC.SingleStep
abandonCmd :: String -> GHCi ()
abandonCmd = noArgs $ do
b <- GHC.abandon -- the prompt will change to indicate the new context
- when (not b) $ io $ putStrLn "There is no computation running."
- return ()
+ when (not b) $ liftIO $ putStrLn "There is no computation running."
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
where
deleteSwitch :: [String] -> GHCi ()
- deleteSwitch [] =
- io $ putStrLn "The delete command requires at least one argument."
+ deleteSwitch [] =
+ liftIO $ putStrLn "The delete command requires at least one argument."
-- delete all break points
deleteSwitch ("*":_rest) = discardActiveBreakPoints
deleteSwitch idents = do
historyCmd arg
| null arg = history 20
| all isDigit arg = history (read arg)
- | otherwise = io $ putStrLn "Syntax: :history [num]"
+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
where
history num = do
resumes <- GHC.getResumeContext
case resumes of
- [] -> io $ putStrLn "Not stopped at a breakpoint"
+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
(r:_) -> do
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
case hist of
- [] -> io $ putStrLn $
+ [] -> liftIO $ putStrLn $
"Empty history. Perhaps you forgot to use :trace?"
_ -> do
spans <- mapM GHC.getHistorySpan took
let nums = map (printf "-%-3d:") [(1::Int)..]
- names = map GHC.historyEnclosingDecl took
+ names = map GHC.historyEnclosingDecls took
printForUser (vcat(zipWith3
(\x y z -> x <+> y <+> z)
(map text nums)
- (map (bold . ppr) names)
+ (map (bold . hcat . punctuate colon . map text) names)
(map (parens . ppr) spans)))
- io $ putStrLn $ if null rest then "<end of history>" else "..."
+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
bold :: SDoc -> SDoc
bold c | do_bold = text start_bold <> c <> text end_bold
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
- withFlattenedDynflags $ breakSwitch $ words argLine
+ breakSwitch $ words argLine
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
- io $ putStrLn "The break command requires at least one argument."
+ liftIO $ putStrLn "The break command requires at least one argument."
breakSwitch (arg1:rest)
| looksLikeModuleName arg1 && not (null rest) = do
mod <- wantInterpretedModule arg1
case toplevel of
(mod : _) -> breakByModuleLine mod (read arg1) rest
[] -> do
- io $ putStrLn "Cannot find default module for breakpoint."
- io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ liftIO $ putStrLn "Cannot find default module for breakpoint."
+ liftIO $ putStrLn "Perhaps no modules are loaded for debugging?"
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
tickArray <- getTickArray mod
(breakArray, _) <- getModBreak mod
case lookupTickTree tickArray of
- Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
Just (tick, span) -> do
- success <- io $ setBreakFlag True breakArray tick
+ success <- liftIO $ setBreakFlag True breakArray tick
if success
then do
(alreadySet, nm) <-
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
-listCmd c = withFlattenedDynflags $ listCmd' c
+listCmd c = listCmd' c
listCmd' :: String -> InputT GHCi ()
listCmd' "" = do
turnOffBreak :: BreakLocation -> GHCi Bool
turnOffBreak loc = do
(arr, _) <- getModBreak (breakModule loc)
- io $ setBreakFlag False arr (breakTick loc)
+ liftIO $ setBreakFlag False arr (breakTick loc)
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
projects / ghc-hetmet.git / blobdiff