import System.IO
import System.IO.Error as IO
import Data.Char
+import Data.Dynamic
import Control.Monad as Monad
import Foreign.StablePtr ( newStablePtr )
builtin_commands = [
("add", tlC$ keepGoingPaths addModule, False, completeFilename),
("browse", keepGoing browseCmd, False, completeModule),
- ("cd", keepGoing changeDirectory, False, completeFilename),
+#ifdef DEBUGGER
+ -- I think that :c should mean :continue rather than :cd, makes more sense
+ -- (pepe 01.11.07)
+ ("continue", const(bkptOptions "continue"), False, completeNone),
+#endif
+ ("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
("e", keepGoing editFile, False, completeFilename),
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("etags", keepGoing createETagsFileCmd, False, completeFilename),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("type", keepGoing typeOfExpr, False, completeIdentifier),
-#if defined(GHCI)
- ("breakpoint",keepGoing bkptOptions, False, completeBkpt),
+#if defined(DEBUGGER)
+ ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+ ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+ ("breakpoint",bkptOptions, False, completeBkpt),
#endif
("kind", keepGoing kindOfType, False, completeIdentifier),
("unset", keepGoing unsetOptions, True, completeSetOptions),
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False
--- tlC: Top Level Command
+-- tlC: Top Level Command, not allowed in inferior sessions
tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
tlC a str = do
top_level <- isTopLevel
" :breakpoint <option> commands for the GHCi debugger\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
+ " :continue equivalent to ':breakpoint continue'\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :sprint [<name> ...] simplified version of :print\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
"\n" ++
" Options for ':breakpoint':\n" ++
" list list the current breakpoints\n" ++
- " add Module line [col] add a new breakpoint\n" ++
+ " add [Module] line [col] add a new breakpoint\n" ++
" del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
+ " continue continue execution\n" ++
" stop Stop a computation and return to the top level\n" ++
" step [count] Step by step execution (DISABLED)\n"
hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session prel_name Nothing
+ prel_mod <- GHC.findModule session prel_name (Just basePackageId)
GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
- refreshBkptTable graph'
+ do
+ bt <- getBkptTable
+ bt' <- io$ refreshBkptTable session bt graph'
+ setBkptTable bt'
modulesLoadedMsg ok (map GHC.ms_mod_name graph')
setContextAfterLoad session [] = do
io (putStrLn (str ++ " :: " ++ tystr))
quit :: String -> GHCi Bool
-quit _ = return True
+quit _ = do in_inferior_session <- liftM not isTopLevel
+ if in_inferior_session
+ then throwDyn StopParentSession
+ else return True
+
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
getCommonPrefix :: [String] -> String
getCommonPrefix [] = ""
getCommonPrefix (s:ss) = foldl common s ss
- where common s "" = s
+ where common s "" = ""
common "" s = ""
common (c:cs) (d:ds)
| c == d = c : common cs ds
completeBkpt = completeNone
#endif
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception. The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- 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 (DynException dyn)
+ | Just StopChildSession <- fromDynamic dyn
+ -- propagate to the parent session
+ = do ASSERTM (liftM not isTopLevel)
+ throwDyn StopChildSession
+
+ | Just StopParentSession <- fromDynamic dyn
+ = do at_topLevel <- isTopLevel
+ if at_topLevel then return True else throwDyn StopParentSession
+
+ | Just (ChildSessionStopped msg) <- fromDynamic dyn
+ = io(putStrLn msg) >> return False
+
+handler exception = do
+ flushInterpBuffers
+ io installSignalHandlers
+ ghciHandle handler (showException exception >> return False)
+
+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))
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- 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 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)
+
+
-- ----------------------------------------------------------------------------
-- Utils
bkptTable= ref_bkptTable,
prelude = prel_mod,
topLevel = False }
- `catchDyn` (
- \StopChildSession -> evaluate$
- throwDyn (ChildSessionStopped "You may need to reload your modules")
+ `catchDyn` (\e -> case e of
+ StopChildSession -> evaluate$
+ throwDyn (ChildSessionStopped "")
+ StopParentSession -> throwDyn StopParentSession
) `finally` do
writeIORef ref hsc_env
putStrLn $ "Returning to normal execution..."
printScopeMsg location ids = do
unqual <- GHC.getPrintUnqual s
printForUser stdout unqual $
- text "Local bindings in scope:" $$
+ text "Stopped at a breakpoint in " <> text (stripColumn location) <>
+ char '.' <+> text "Local bindings in scope:" $$
nest 2 (pprWithCommas showId ids)
where
showId id =
ppr (idName id) <+> dcolon <+> ppr (idType id)
+ stripColumn = reverse . tail . dropWhile (/= ':') . reverse
-- | Give the Id a Global Name, and tidy its type
globaliseAndTidy :: Id -> Id