import Data.Dynamic
import Data.Array
import Control.Monad as Monad
+import Text.Printf
import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
- " <stmt> evaluate/run <stmt>\n" ++
+ " <statement> evaluate/run <statement>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :abandon at a breakpoint, abandon current computation\n" ++
- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
- " :break <name> set a breakpoint on the specified function\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
- " :continue resume after a breakpoint\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
- " :delete <number> delete the specified breakpoint\n" ++
- " :delete * delete all breakpoints\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
" :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
--- " :force <expr> print <expr>, forcing unevaluated parts\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" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
- " :print [<name> ...] prints a value without forcing its computation\n" ++
" :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
+ " :type <expr> show the type of <expr>\n" ++
+ " :undef <cmd> undefine user-defined command :<cmd>\n" ++
+ " :!<command> run the shell command <command>\n" ++
+ "\n" ++
+ " -- Commands for debugging:\n" ++
+ "\n" ++
+ " :abandon at a breakpoint, abandon current computation\n" ++
+ " :back go back in the history (after :trace)\n" ++
+ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
+ " :break <name> set a breakpoint on the specified function\n" ++
+ " :continue resume after a breakpoint\n" ++
+ " :delete <number> delete the specified breakpoint\n" ++
+ " :delete * delete all breakpoints\n" ++
+ " :force <expr> print <expr>, forcing unevaluated parts\n" ++
+ " :forward go forward in the history (after :back)\n" ++
+ " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :step single-step after stopping at a breakpoint\n"++
+ " :step <expr> single-step into <expr>\n"++
+ " :trace trace after stopping at a breakpoint\n"++
+ " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
+
+ "\n" ++
+ " -- Commands for changing settings:\n" ++
"\n" ++
" :set <option> ... set options\n" ++
" :set args <arg> ... set the arguments returned by System.getArgs\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" ++
- "\n" ++
- " :show breaks show active breakpoints\n" ++
- " :show context show the breakpoint context\n" ++
- " :show modules show the currently loaded modules\n" ++
- " :show bindings show the current bindings made at the prompt\n" ++
- "\n" ++
- " :sprint [<name> ...] simplifed version of :print\n" ++
- " :step single-step after stopping at a breakpoint\n"++
- " :step <expr> single-step into <expr>\n"++
- " :type <expr> show the type of <expr>\n" ++
- " :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :unset <option> ... unset options\n" ++
- " :!<command> run the shell command <command>\n" ++
"\n" ++
- " Options for ':set' and ':unset':\n" ++
+ " Options for ':set' and ':unset':\n" ++
"\n" ++
" +r revert top-level expressions after each evaluation\n" ++
" +s print timing/memory stats after each evaluation\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ "\n" ++
+ " -- Commands for displaying information:\n" ++
+ "\n" ++
+ " :show bindings show the current bindings made at the prompt\n" ++
+ " :show breaks show the active breakpoints\n" ++
+ " :show context show the breakpoint context\n" ++
+ " :show modules show the currently loaded modules\n" ++
+ " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
"\n"
--- Todo: add help for breakpoint commands here
findEditor = do
getEnv "EDITOR"
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
afterRunStmt result
- return False
+ return (isRunResultOk result)
afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
return (Just (True,names))
+isRunResultOk :: GHC.RunResult -> Bool
+isRunResultOk (GHC.RunOk _) = True
+isRunResultOk _ = False
+
+
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
= do maybe_tything <- io (GHC.lookupName session n)
browseModule m exports_only = do
s <- getSession
- modl <- if exports_only then lookupModule s m
- else wantInterpretedModule s m
+ modl <- if exports_only then lookupModule m
+ else wantInterpretedModule m
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
do -- first, deal with the GHCi opts (+s, +t, etc.)
let (plus_opts, minus_opts) = partition isPlus wds
mapM_ setOpt plus_opts
-
-- then, dynamic flags
+ newDynFlags minus_opts
+
+newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
(dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
mapM_ unsetOpt plus_opts
- -- can't do GHC flags for now
- if (not (null minus_opts))
- then throwDyn (CmdLineError "can't unset GHC command-line flags")
- else return ()
+ let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+ no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
+
+ no_flags <- mapM no_flag minus_opts
+ newDynFlags no_flags
isMinus ('-':s) = True
isMinus _ = False
-- ---------------------------------------------------------------------------
-- code for `:show'
-showCmd str =
+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))
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> io showLinkerState
- ["breaks"] -> showBkptTable
- ["context"] -> showContext
- _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
+ ["breaks"] -> showBkptTable
+ ["context"] -> showContext
+ _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
showModules = do
session <- getSession
other ->
return other
+wantInterpretedModule :: String -> GHCi Module
+wantInterpretedModule str = do
+ session <- getSession
+ modl <- lookupModule str
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ return modl
+
+wantNameFromInterpretedModule noCanDo str and_then = do
+ session <- getSession
+ names <- io $ GHC.parseName session str
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let modl = GHC.nameModule n
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
+
-- ----------------------------------------------------------------------------
-- Windows console setup
| otherwise = return ()
historyCmd :: String -> GHCi ()
-historyCmd = noArgs $ do
- s <- getSession
- resumes <- io $ GHC.getResumeContext s
- case resumes of
- [] -> io $ putStrLn "Not stopped at a breakpoint"
- (r:rs) -> do
- let hist = GHC.resumeHistory r
- spans <- mapM (io . GHC.getHistorySpan s) hist
- printForUser (vcat (map ppr spans))
+historyCmd arg
+ | null arg = history 20
+ | all isDigit arg = history (read arg)
+ | otherwise = io $ putStrLn "Syntax: :history [num]"
+ where
+ history num = do
+ s <- getSession
+ resumes <- io $ GHC.getResumeContext s
+ case resumes of
+ [] -> io $ putStrLn "Not stopped at a breakpoint"
+ (r:rs) -> do
+ let hist = GHC.resumeHistory r
+ (took,rest) = splitAt num hist
+ spans <- mapM (io . GHC.getHistorySpan s) took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+ io $ putStrLn $ if null rest then "<end of history>" else "..."
backCmd :: String -> GHCi ()
backCmd = noArgs $ do
io $ putStrLn "The break command requires at least one argument."
breakSwitch session args@(arg1:rest)
| looksLikeModuleName arg1 = do
- mod <- wantInterpretedModule session arg1
+ mod <- wantInterpretedModule arg1
breakByModule session mod rest
| all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
[] -> do
io $ putStrLn "Cannot find default module for breakpoint."
io $ putStrLn "Perhaps no modules are loaded for debugging?"
- | otherwise = do -- assume it's a name
- names <- io $ GHC.parseName session arg1
- case names of
- [] -> return ()
- (n:_) -> do
- let loc = GHC.nameSrcLoc n
- modl = GHC.nameModule n
- is_interpreted <- io (GHC.moduleIsInterpreted session modl)
- if not is_interpreted
- then noCanDo $ text "module " <> ppr modl <>
- text " is not interpreted"
- else do
- if GHC.isGoodSrcLoc loc
- then findBreakAndSet (GHC.nameModule n) $
+ | otherwise = do -- try parsing it as an identifier
+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+ let loc = GHC.nameSrcLoc name
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule name) $
findBreakByCoord (Just (GHC.srcLocFile loc))
(GHC.srcLocLine loc,
GHC.srcLocCol loc)
- else noCanDo $ text "can't find its location: " <>
- ppr loc
- where
- noCanDo why = printForUser $
+ else noCanDo name $ text "can't find its location: " <> ppr loc
+ where
+ noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-
-wantInterpretedModule :: Session -> String -> GHCi Module
-wantInterpretedModule session str = do
- modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
- is_interpreted <- io (GHC.moduleIsInterpreted session modl)
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
- return modl
-
breakByModule :: Session -> Module -> [String] -> GHCi ()
breakByModule session mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
end_bold = BS.pack "\ESC[0m"
listCmd :: String -> GHCi ()
-listCmd str = do
+listCmd "" = do
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
Just span -> io $ listAround span True
+listCmd str = list2 (words str)
+
+list2 [arg] | all isDigit arg = do
+ session <- getSession
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ [] -> io $ putStrLn "No module to list"
+ (mod : _) -> listModuleLine mod (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+ mod <- wantInterpretedModule arg1
+ listModuleLine mod (read arg2)
+list2 [arg] = do
+ wantNameFromInterpretedModule noCanDo arg $ \name -> do
+ let loc = GHC.nameSrcLoc name
+ if GHC.isGoodSrcLoc loc
+ then do
+ tickArray <- getTickArray (GHC.nameModule name)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ tickArray
+ case mb_span of
+ Nothing -> io $ listAround (GHC.srcLocSpan loc) False
+ Just (_,span) -> io $ listAround span False
+ else
+ noCanDo name $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot list source code for " <> ppr n <> text ": " <> why
+list2 _other =
+ io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: Module -> Int -> GHCi ()
+listModuleLine modl line = do
+ session <- getSession
+ graph <- io (GHC.getModuleGraph session)
+ let this = filter ((== modl) . GHC.ms_mod) graph
+ case this of
+ [] -> panic "listModuleLine"
+ summ:_ -> do
+ let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+ loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
+ io $ listAround (GHC.srcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
-lookupModule :: Session -> String -> GHCi Module
-lookupModule session modName
- = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+lookupModule :: String -> GHCi Module
+lookupModule modName
+ = do session <- getSession
+ io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-- don't reset the counter back to zero?
discardActiveBreakPoints :: GHCi ()