1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Type, Module, ModuleName, TyThing(..), Phase,
29 import Outputable hiding (printForUser)
30 import Module -- for ModuleEnv
37 -- Other random utilities
39 import BasicTypes hiding (isTopLevel)
40 import Panic hiding (showException)
46 #ifndef mingw32_HOST_OS
48 #if __GLASGOW_HASKELL__ > 504
52 import GHC.ConsoleHandler ( flushConsole )
53 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
54 import qualified System.Win32
58 import Control.Concurrent ( yield ) -- Used in readline loop
59 import System.Console.Readline as Readline
64 import Control.Exception as Exception
65 -- import Control.Concurrent
70 import System.Environment
71 import System.Exit ( exitWith, ExitCode(..) )
72 import System.Directory
74 import System.IO.Error as IO
78 import Control.Monad as Monad
80 import Foreign.StablePtr ( newStablePtr )
81 import GHC.Exts ( unsafeCoerce# )
82 import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) )
84 import Data.IORef ( IORef, readIORef, writeIORef )
86 import System.Posix.Internals ( setNonBlockingFD )
88 -- these are needed by the new ghci debugger
89 import ByteCodeLink (HValue)
90 import ByteCodeInstr (BreakInfo (..))
93 -----------------------------------------------------------------------------
97 " / _ \\ /\\ /\\/ __(_)\n"++
98 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
99 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
100 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
102 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
103 cmdName (n,_,_,_) = n
105 GLOBAL_VAR(commands, builtin_commands, [Command])
107 builtin_commands :: [Command]
109 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
110 ("?", keepGoing help, False, completeNone),
111 ("add", keepGoingPaths addModule, False, completeFilename),
112 ("break", breakCmd, False, completeNone),
113 ("browse", keepGoing browseCmd, False, completeModule),
114 ("cd", keepGoing changeDirectory, False, completeFilename),
115 ("check", keepGoing checkModule, False, completeHomeModule),
116 ("continue", continueCmd, False, completeNone),
117 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
118 ("def", keepGoing defineMacro, False, completeIdentifier),
119 ("delete", deleteCmd, False, completeNone),
120 ("e", keepGoing editFile, False, completeFilename),
121 ("edit", keepGoing editFile, False, completeFilename),
122 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
123 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
124 ("help", keepGoing help, False, completeNone),
125 ("info", keepGoing info, False, completeIdentifier),
126 ("kind", keepGoing kindOfType, False, completeIdentifier),
127 ("load", keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
128 ("module", keepGoing setContext, False, completeModule),
129 ("main", keepGoing runMain, False, completeIdentifier),
130 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
131 ("quit", quit, False, completeNone),
132 ("reload", keepGoing reloadModule, False, completeNone),
133 ("set", keepGoing setCmd, True, completeSetOptions),
134 ("show", keepGoing showCmd, False, completeNone),
135 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
136 ("step", stepCmd, False, completeNone),
137 ("type", keepGoing typeOfExpr, False, completeIdentifier),
138 ("undef", keepGoing undefineMacro, False, completeMacro),
139 ("unset", keepGoing unsetOptions, True, completeSetOptions)
142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
143 keepGoing a str = a str >> return False
145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
146 keepGoingPaths a str = a (toArgs str) >> return False
148 shortHelpText = "use :? for help.\n"
150 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
152 " Commands available from the prompt:\n" ++
154 " <stmt> evaluate/run <stmt>\n" ++
155 " :add <filename> ... add module(s) to the current target set\n" ++
156 " :browse [*]<module> display the names defined by <module>\n" ++
157 " :cd <dir> change directory to <dir>\n" ++
158 " :def <cmd> <expr> define a command :<cmd>\n" ++
159 " :edit <file> edit file\n" ++
160 " :edit edit last module\n" ++
161 " :help, :? display this list of commands\n" ++
162 " :info [<name> ...] display information about the given names\n" ++
163 " :print [<name> ...] prints a value without forcing its computation\n" ++
164 " :sprint [<name> ...] simplified version of :print\n" ++
165 " :load <filename> ... load module(s) and their dependents\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :main [<arguments> ...] run the main function with the given arguments\n" ++
168 " :reload reload the current module set\n" ++
170 " :set <option> ... set options\n" ++
171 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
172 " :set prog <progname> set the value returned by System.getProgName\n" ++
173 " :set prompt <prompt> set the prompt used in GHCi\n" ++
174 " :set editor <cmd> set the command used for :edit\n" ++
176 " :show modules show the currently loaded modules\n" ++
177 " :show bindings show the current bindings made at the prompt\n" ++
179 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
180 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
181 " :type <expr> show the type of <expr>\n" ++
182 " :kind <type> show the kind of <type>\n" ++
183 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
184 " :unset <option> ... unset options\n" ++
185 " :quit exit GHCi\n" ++
186 " :!<command> run the shell command <command>\n" ++
188 " Options for ':set' and ':unset':\n" ++
190 " +r revert top-level expressions after each evaluation\n" ++
191 " +s print timing/memory stats after each evaluation\n" ++
192 " +t print type after evaluation\n" ++
193 " -<flags> most GHC command line flags can also be set here\n" ++
194 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
196 -- Todo: add help for breakpoint commands here
202 win <- System.Win32.getWindowsDirectory
203 return (win `joinFileName` "notepad.exe")
208 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
209 interactiveUI session srcs maybe_expr = do
210 -- HACK! If we happen to get into an infinite loop (eg the user
211 -- types 'let x=x in x' at the prompt), then the thread will block
212 -- on a blackhole, and become unreachable during GC. The GC will
213 -- detect that it is unreachable and send it the NonTermination
214 -- exception. However, since the thread is unreachable, everything
215 -- it refers to might be finalized, including the standard Handles.
216 -- This sounds like a bug, but we don't have a good solution right
222 -- Initialise buffering for the *interpreted* I/O system
223 initInterpBuffering session
225 when (isNothing maybe_expr) $ do
226 -- Only for GHCi (not runghc and ghc -e):
227 -- Turn buffering off for the compiled program's stdout/stderr
229 -- Turn buffering off for GHCi's stdout
231 hSetBuffering stdout NoBuffering
232 -- We don't want the cmd line to buffer any input that might be
233 -- intended for the program, so unbuffer stdin.
234 hSetBuffering stdin NoBuffering
236 -- initial context is just the Prelude
237 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
238 GHC.setContext session [] [prel_mod]
242 Readline.setAttemptedCompletionFunction (Just completeWord)
243 --Readline.parseAndBind "set show-all-if-ambiguous 1"
245 let symbols = "!#$%&*+/<=>?@\\^|-~"
246 specials = "(),;[]`{}"
248 word_break_chars = spaces ++ specials ++ symbols
250 Readline.setBasicWordBreakCharacters word_break_chars
251 Readline.setCompleterWordBreakCharacters word_break_chars
254 default_editor <- findEditor
256 startGHCi (runGHCi srcs maybe_expr)
257 GHCiState{ progname = "<interactive>",
260 editor = default_editor,
265 breaks = emptyActiveBreakPoints,
266 tickarrays = emptyModuleEnv
270 Readline.resetTerminal Nothing
275 prel_name = GHC.mkModuleName "Prelude"
277 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
278 runGHCi paths maybe_expr = do
279 let read_dot_files = not opt_IgnoreDotGhci
281 when (read_dot_files) $ do
284 exists <- io (doesFileExist file)
286 dir_ok <- io (checkPerms ".")
287 file_ok <- io (checkPerms file)
288 when (dir_ok && file_ok) $ do
289 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
292 Right hdl -> fileLoop hdl False
294 when (read_dot_files) $ do
295 -- Read in $HOME/.ghci
296 either_dir <- io (IO.try (getEnv "HOME"))
300 cwd <- io (getCurrentDirectory)
301 when (dir /= cwd) $ do
302 let file = dir ++ "/.ghci"
303 ok <- io (checkPerms file)
305 either_hdl <- io (IO.try (openFile file ReadMode))
308 Right hdl -> fileLoop hdl False
310 -- Perform a :load for files given on the GHCi command line
311 -- When in -e mode, if the load fails then we want to stop
312 -- immediately rather than going on to evaluate the expression.
313 when (not (null paths)) $ do
314 ok <- ghciHandle (\e -> do showException e; return Failed) $
316 when (isJust maybe_expr && failed ok) $
317 io (exitWith (ExitFailure 1))
319 -- if verbosity is greater than 0, or we are connected to a
320 -- terminal, display the prompt in the interactive loop.
321 is_tty <- io (hIsTerminalDevice stdin)
322 dflags <- getDynFlags
323 let show_prompt = verbosity dflags > 0 || is_tty
328 #if defined(mingw32_HOST_OS)
329 -- The win32 Console API mutates the first character of
330 -- type-ahead when reading from it in a non-buffered manner. Work
331 -- around this by flushing the input buffer of type-ahead characters,
332 -- but only if stdin is available.
333 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
335 Left err | isDoesNotExistError err -> return ()
336 | otherwise -> io (ioError err)
337 Right () -> return ()
339 -- initialise the console if necessary
342 -- enter the interactive loop
343 interactiveLoop is_tty show_prompt
345 -- just evaluate the expression we were given
350 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
353 interactiveLoop is_tty show_prompt =
354 -- Ignore ^C exceptions caught here
355 ghciHandleDyn (\e -> case e of
357 #if defined(mingw32_HOST_OS)
360 interactiveLoop is_tty show_prompt
361 _other -> return ()) $
363 ghciUnblock $ do -- unblock necessary if we recursed from the
364 -- exception handler above.
366 -- read commands from stdin
370 else fileLoop stdin show_prompt
372 fileLoop stdin show_prompt
376 -- NOTE: We only read .ghci files if they are owned by the current user,
377 -- and aren't world writable. Otherwise, we could be accidentally
378 -- running code planted by a malicious third party.
380 -- Furthermore, We only read ./.ghci if . is owned by the current user
381 -- and isn't writable by anyone else. I think this is sufficient: we
382 -- don't need to check .. and ../.. etc. because "." always refers to
383 -- the same directory while a process is running.
385 checkPerms :: String -> IO Bool
387 #ifdef mingw32_HOST_OS
390 Util.handle (\_ -> return False) $ do
391 st <- getFileStatus name
393 if fileOwner st /= me then do
394 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
397 let mode = fileMode st
398 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
399 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
401 putStrLn $ "*** WARNING: " ++ name ++
402 " is writable by someone else, IGNORING!"
407 fileLoop :: Handle -> Bool -> GHCi ()
408 fileLoop hdl show_prompt = do
409 session <- getSession
410 (mod,imports) <- io (GHC.getContext session)
412 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
413 l <- io (IO.try (hGetLine hdl))
415 Left e | isEOFError e -> return ()
416 | InvalidArgument <- etype -> return ()
417 | otherwise -> io (ioError e)
418 where etype = ioeGetErrorType e
419 -- treat InvalidArgument in the same way as EOF:
420 -- this can happen if the user closed stdin, or
421 -- perhaps did getContents which closes stdin at
424 case removeSpaces l of
425 "" -> fileLoop hdl show_prompt
426 l -> do quit <- runCommand l
427 if quit then return () else fileLoop hdl show_prompt
429 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
430 stringLoop [] = return False
431 stringLoop (s:ss) = do
432 case removeSpaces s of
434 l -> do quit <- runCommand l
435 if quit then return True else stringLoop ss
437 mkPrompt toplevs exports prompt
438 = showSDoc $ f prompt
440 f ('%':'s':xs) = perc_s <> f xs
441 f ('%':'%':xs) = char '%' <> f xs
442 f (x:xs) = char x <> f xs
445 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
446 hsep (map (ppr . GHC.moduleName) exports)
450 readlineLoop :: GHCi ()
452 session <- getSession
453 (mod,imports) <- io (GHC.getContext session)
455 saveSession -- for use by completion
457 l <- io (readline (mkPrompt mod imports (prompt st))
458 `finally` setNonBlockingFD 0)
459 -- readline sometimes puts stdin into blocking mode,
460 -- so we need to put it back for the IO library
465 case removeSpaces l of
470 if quit then return () else readlineLoop
473 runCommand :: String -> GHCi Bool
474 runCommand c = ghciHandle handler (doCommand c)
476 doCommand (':' : command) = specialCommand command
478 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
481 -- This version is for the GHC command-line option -e. The only difference
482 -- from runCommand is that it catches the ExitException exception and
483 -- exits, rather than printing out the exception.
484 runCommandEval c = ghciHandle handleEval (doCommand c)
486 handleEval (ExitException code) = io (exitWith code)
487 handleEval e = do handler e
488 io (exitWith (ExitFailure 1))
490 doCommand (':' : command) = specialCommand command
492 = do nms <- runStmt stmt
494 Nothing -> io (exitWith (ExitFailure 1))
495 -- failure to run the command causes exit(1) for ghc -e.
496 _ -> finishEvalExpr nms
498 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
500 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
502 = do st <- getGHCiState
503 session <- getSession
504 result <- io $ withProgName (progname st) $ withArgs (args st) $
505 GHC.runStmt session stmt
506 switchOnRunResult result
508 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
509 switchOnRunResult GHC.RunFailed = return Nothing
510 switchOnRunResult (GHC.RunException e) = throw e
511 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
512 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
513 session <- getSession
514 Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
515 let modBreaks = GHC.modInfoModBreaks mod_info
516 let ticks = GHC.modBreaks_locs modBreaks
518 -- display information about the breakpoint
519 let location = ticks ! breakInfo_number info
520 printForUser $ ptext SLIT("Stopped at") <+> ppr location
522 pushResume location threadId resume
523 return (Just (True,names))
525 -- possibly print the type and revert CAFs after evaluating an expression
526 finishEvalExpr mb_names
527 = do show_types <- isOptionSet ShowType
528 session <- getSession
531 Just (is_break,names) ->
532 when (is_break || show_types) $
533 mapM_ (showTypeOfName session) names
536 io installSignalHandlers
537 b <- isOptionSet RevertCAFs
538 io (when b revertCAFs)
541 showTypeOfName :: Session -> Name -> GHCi ()
542 showTypeOfName session n
543 = do maybe_tything <- io (GHC.lookupName session n)
544 case maybe_tything of
546 Just thing -> showTyThing thing
548 specialCommand :: String -> GHCi Bool
549 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
550 specialCommand str = do
551 let (cmd,rest) = break isSpace str
552 maybe_cmd <- io (lookupCommand cmd)
554 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
555 ++ shortHelpText) >> return False)
556 Just (_,f,_,_) -> f (dropWhile isSpace rest)
558 lookupCommand :: String -> IO (Maybe Command)
559 lookupCommand str = do
560 cmds <- readIORef commands
561 -- look for exact match first, then the first prefix match
562 case [ c | c <- cmds, str == cmdName c ] of
563 c:_ -> return (Just c)
564 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
566 c:_ -> return (Just c)
568 -----------------------------------------------------------------------------
571 help :: String -> GHCi ()
572 help _ = io (putStr helpText)
574 info :: String -> GHCi ()
575 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
576 info s = do { let names = words s
577 ; session <- getSession
578 ; dflags <- getDynFlags
579 ; let exts = dopt Opt_GlasgowExts dflags
580 ; mapM_ (infoThing exts session) names }
582 infoThing exts session str = io $ do
583 names <- GHC.parseName session str
584 let filtered = filterOutChildren names
585 mb_stuffs <- mapM (GHC.getInfo session) filtered
586 unqual <- GHC.getPrintUnqual session
587 putStrLn (showSDocForUser unqual $
588 vcat (intersperse (text "") $
589 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
591 -- Filter out names whose parent is also there Good
592 -- example is '[]', which is both a type and data
593 -- constructor in the same type
594 filterOutChildren :: [Name] -> [Name]
595 filterOutChildren names = filter (not . parent_is_there) names
596 where parent_is_there n
597 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
601 pprInfo exts (thing, fixity, insts)
602 = pprTyThingInContextLoc exts thing
603 $$ show_fixity fixity
604 $$ vcat (map GHC.pprInstance insts)
607 | fix == GHC.defaultFixity = empty
608 | otherwise = ppr fix <+> ppr (GHC.getName thing)
610 -----------------------------------------------------------------------------
613 runMain :: String -> GHCi ()
615 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
616 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
619 addModule :: [FilePath] -> GHCi ()
621 io (revertCAFs) -- always revert CAFs on load/add.
622 files <- mapM expandPath files
623 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
624 session <- getSession
625 io (mapM_ (GHC.addTarget session) targets)
626 ok <- io (GHC.load session LoadAllTargets)
629 changeDirectory :: String -> GHCi ()
630 changeDirectory dir = do
631 session <- getSession
632 graph <- io (GHC.getModuleGraph session)
633 when (not (null graph)) $
634 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
635 io (GHC.setTargets session [])
636 io (GHC.load session LoadAllTargets)
637 setContextAfterLoad session []
638 io (GHC.workingDirectoryChanged session)
639 dir <- expandPath dir
640 io (setCurrentDirectory dir)
642 editFile :: String -> GHCi ()
645 -- find the name of the "topmost" file loaded
646 session <- getSession
647 graph0 <- io (GHC.getModuleGraph session)
648 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
649 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
650 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
651 Just file -> do_edit file
652 Nothing -> throwDyn (CmdLineError "unknown file name")
653 | otherwise = do_edit str
659 throwDyn (CmdLineError "editor not set, use :set editor")
660 io $ system (cmd ++ ' ':file)
663 defineMacro :: String -> GHCi ()
665 let (macro_name, definition) = break isSpace s
666 cmds <- io (readIORef commands)
668 then throwDyn (CmdLineError "invalid macro name")
670 if (macro_name `elem` map cmdName cmds)
671 then throwDyn (CmdLineError
672 ("command '" ++ macro_name ++ "' is already defined"))
675 -- give the expression a type signature, so we can be sure we're getting
676 -- something of the right type.
677 let new_expr = '(' : definition ++ ") :: String -> IO String"
679 -- compile the expression
681 maybe_hv <- io (GHC.compileExpr cms new_expr)
684 Just hv -> io (writeIORef commands --
685 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
687 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
689 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
690 stringLoop (lines str)
692 undefineMacro :: String -> GHCi ()
693 undefineMacro macro_name = do
694 cmds <- io (readIORef commands)
695 if (macro_name `elem` map cmdName builtin_commands)
696 then throwDyn (CmdLineError
697 ("command '" ++ macro_name ++ "' cannot be undefined"))
699 if (macro_name `notElem` map cmdName cmds)
700 then throwDyn (CmdLineError
701 ("command '" ++ macro_name ++ "' not defined"))
703 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
706 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
707 loadModule fs = timeIt (loadModule' fs)
709 loadModule_ :: [FilePath] -> GHCi ()
710 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
712 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
713 loadModule' files = do
714 session <- getSession
717 io (GHC.setTargets session [])
718 io (GHC.load session LoadAllTargets)
721 let (filenames, phases) = unzip files
722 exp_filenames <- mapM expandPath filenames
723 let files' = zip exp_filenames phases
724 targets <- io (mapM (uncurry GHC.guessTarget) files')
726 -- NOTE: we used to do the dependency anal first, so that if it
727 -- fails we didn't throw away the current set of modules. This would
728 -- require some re-working of the GHC interface, so we'll leave it
729 -- as a ToDo for now.
731 io (GHC.setTargets session targets)
732 ok <- io (GHC.load session LoadAllTargets)
736 checkModule :: String -> GHCi ()
738 let modl = GHC.mkModuleName m
739 session <- getSession
740 result <- io (GHC.checkModule session modl)
742 Nothing -> io $ putStrLn "Nothing"
743 Just r -> io $ putStrLn (showSDoc (
744 case GHC.checkedModuleInfo r of
745 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
747 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
749 (text "global names: " <+> ppr global) $$
750 (text "local names: " <+> ppr local)
752 afterLoad (successIf (isJust result)) session
754 reloadModule :: String -> GHCi ()
756 io (revertCAFs) -- always revert CAFs on reload.
757 session <- getSession
758 ok <- io (GHC.load session LoadAllTargets)
761 io (revertCAFs) -- always revert CAFs on reload.
762 session <- getSession
763 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
766 afterLoad ok session = do
767 io (revertCAFs) -- always revert CAFs on load.
770 discardActiveBreakPoints
771 graph <- io (GHC.getModuleGraph session)
772 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
773 setContextAfterLoad session graph'
774 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
776 setContextAfterLoad session [] = do
777 prel_mod <- getPrelude
778 io (GHC.setContext session [] [prel_mod])
779 setContextAfterLoad session ms = do
780 -- load a target if one is available, otherwise load the topmost module.
781 targets <- io (GHC.getTargets session)
782 case [ m | Just m <- map (findTarget ms) targets ] of
784 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
785 load_this (last graph')
790 = case filter (`matches` t) ms of
794 summary `matches` Target (TargetModule m) _
795 = GHC.ms_mod_name summary == m
796 summary `matches` Target (TargetFile f _) _
797 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
798 summary `matches` target
801 load_this summary | m <- GHC.ms_mod summary = do
802 b <- io (GHC.moduleIsInterpreted session m)
803 if b then io (GHC.setContext session [m] [])
805 prel_mod <- getPrelude
806 io (GHC.setContext session [] [prel_mod,m])
809 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
810 modulesLoadedMsg ok mods = do
811 dflags <- getDynFlags
812 when (verbosity dflags > 0) $ do
814 | null mods = text "none."
816 punctuate comma (map ppr mods)) <> text "."
819 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
821 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
824 typeOfExpr :: String -> GHCi ()
826 = do cms <- getSession
827 maybe_ty <- io (GHC.exprType cms str)
830 Just ty -> do ty' <- cleanType ty
831 printForUser $ text str <> text " :: " <> ppr ty'
833 kindOfType :: String -> GHCi ()
835 = do cms <- getSession
836 maybe_ty <- io (GHC.typeKind cms str)
839 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
841 quit :: String -> GHCi Bool
844 shellEscape :: String -> GHCi Bool
845 shellEscape str = io (system str >> return False)
847 -----------------------------------------------------------------------------
848 -- create tags file for currently loaded modules.
850 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
852 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
853 createCTagsFileCmd file = ghciCreateTagsFile CTags file
855 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
856 createETagsFileCmd file = ghciCreateTagsFile ETags file
858 data TagsKind = ETags | CTags
860 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
861 ghciCreateTagsFile kind file = do
862 session <- getSession
863 io $ createTagsFile session kind file
866 -- - remove restriction that all modules must be interpreted
867 -- (problem: we don't know source locations for entities unless
868 -- we compiled the module.
870 -- - extract createTagsFile so it can be used from the command-line
871 -- (probably need to fix first problem before this is useful).
873 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
874 createTagsFile session tagskind tagFile = do
875 graph <- GHC.getModuleGraph session
876 let ms = map GHC.ms_mod graph
878 is_interpreted <- GHC.moduleIsInterpreted session m
879 -- should we just skip these?
880 when (not is_interpreted) $
881 throwDyn (CmdLineError ("module '"
882 ++ GHC.moduleNameString (GHC.moduleName m)
883 ++ "' is not interpreted"))
884 mbModInfo <- GHC.getModuleInfo session m
886 | Just modinfo <- mbModInfo,
887 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
888 | otherwise = GHC.alwaysQualify
891 Just modInfo -> return $! listTags unqual modInfo
894 mtags <- mapM tagModule ms
895 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
897 Left e -> hPutStrLn stderr $ ioeGetErrorString e
900 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
901 listTags unqual modInfo =
902 [ tagInfo unqual name loc
903 | name <- GHC.modInfoExports modInfo
904 , let loc = nameSrcLoc name
908 type TagInfo = (String -- tag name
911 ,Int -- column number
914 -- get tag info, for later translation into Vim or Emacs style
915 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
916 tagInfo unqual name loc
917 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
918 , showSDocForUser unqual $ ftext (srcLocFile loc)
923 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
924 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
925 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
926 IO.try (writeFile file tags)
927 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
928 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
929 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
930 tagGroups <- mapM tagFileGroup groups
931 IO.try (writeFile file $ concat tagGroups)
933 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
934 tagFileGroup group@((_,fileName,_,_):_) = do
935 file <- readFile fileName -- need to get additional info from sources..
936 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
937 sortedGroup = sortLe byLine group
938 tags = unlines $ perFile sortedGroup 1 0 $ lines file
939 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
940 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
941 perFile (tagInfo:tags) (count+1) (pos+length line) lines
942 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
943 showETag tagInfo line pos : perFile tags count pos lines
944 perFile tags count pos lines = []
946 -- simple ctags format, for Vim et al
947 showTag :: TagInfo -> String
948 showTag (tag,file,lineNo,colNo)
949 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
951 -- etags format, for Emacs/XEmacs
952 showETag :: TagInfo -> String -> Int -> String
953 showETag (tag,file,lineNo,colNo) line charPos
954 = take colNo line ++ tag
956 ++ "\x01" ++ show lineNo
957 ++ "," ++ show charPos
959 -----------------------------------------------------------------------------
960 -- Browsing a module's contents
962 browseCmd :: String -> GHCi ()
965 ['*':m] | looksLikeModuleName m -> browseModule m False
966 [m] | looksLikeModuleName m -> browseModule m True
967 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
969 browseModule m exports_only = do
971 modl <- if exports_only then lookupModule s m
972 else wantInterpretedModule s m
974 -- Temporarily set the context to the module we're interested in,
975 -- just so we can get an appropriate PrintUnqualified
976 (as,bs) <- io (GHC.getContext s)
977 prel_mod <- getPrelude
978 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
979 else GHC.setContext s [modl] [])
980 unqual <- io (GHC.getPrintUnqual s)
981 io (GHC.setContext s as bs)
983 mb_mod_info <- io $ GHC.getModuleInfo s modl
985 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
988 | exports_only = GHC.modInfoExports mod_info
989 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
991 filtered = filterOutChildren names
993 things <- io $ mapM (GHC.lookupName s) filtered
995 dflags <- getDynFlags
996 let exts = dopt Opt_GlasgowExts dflags
997 io (putStrLn (showSDocForUser unqual (
998 vcat (map (pprTyThingInContext exts) (catMaybes things))
1000 -- ToDo: modInfoInstances currently throws an exception for
1001 -- package modules. When it works, we can do this:
1002 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1004 -----------------------------------------------------------------------------
1005 -- Setting the module context
1008 | all sensible mods = fn mods
1009 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1011 (fn, mods) = case str of
1012 '+':stuff -> (addToContext, words stuff)
1013 '-':stuff -> (removeFromContext, words stuff)
1014 stuff -> (newContext, words stuff)
1016 sensible ('*':m) = looksLikeModuleName m
1017 sensible m = looksLikeModuleName m
1019 separate :: Session -> [String] -> [Module] -> [Module]
1020 -> GHCi ([Module],[Module])
1021 separate session [] as bs = return (as,bs)
1022 separate session (('*':str):ms) as bs = do
1023 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1024 b <- io $ GHC.moduleIsInterpreted session m
1025 if b then separate session ms (m:as) bs
1026 else throwDyn (CmdLineError ("module '"
1027 ++ GHC.moduleNameString (GHC.moduleName m)
1028 ++ "' is not interpreted"))
1029 separate session (str:ms) as bs = do
1030 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1031 separate session ms as (m:bs)
1033 newContext :: [String] -> GHCi ()
1034 newContext strs = do
1036 (as,bs) <- separate s strs [] []
1037 prel_mod <- getPrelude
1038 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1039 io $ GHC.setContext s as bs'
1042 addToContext :: [String] -> GHCi ()
1043 addToContext strs = do
1045 (as,bs) <- io $ GHC.getContext s
1047 (new_as,new_bs) <- separate s strs [] []
1049 let as_to_add = new_as \\ (as ++ bs)
1050 bs_to_add = new_bs \\ (as ++ bs)
1052 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1055 removeFromContext :: [String] -> GHCi ()
1056 removeFromContext strs = do
1058 (as,bs) <- io $ GHC.getContext s
1060 (as_to_remove,bs_to_remove) <- separate s strs [] []
1062 let as' = as \\ (as_to_remove ++ bs_to_remove)
1063 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1065 io $ GHC.setContext s as' bs'
1067 ----------------------------------------------------------------------------
1070 -- set options in the interpreter. Syntax is exactly the same as the
1071 -- ghc command line, except that certain options aren't available (-C,
1074 -- This is pretty fragile: most options won't work as expected. ToDo:
1075 -- figure out which ones & disallow them.
1077 setCmd :: String -> GHCi ()
1079 = do st <- getGHCiState
1080 let opts = options st
1081 io $ putStrLn (showSDoc (
1082 text "options currently set: " <>
1085 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1088 = case toArgs str of
1089 ("args":args) -> setArgs args
1090 ("prog":prog) -> setProg prog
1091 ("prompt":prompt) -> setPrompt (after 6)
1092 ("editor":cmd) -> setEditor (after 6)
1093 wds -> setOptions wds
1094 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1098 setGHCiState st{ args = args }
1102 setGHCiState st{ progname = prog }
1104 io (hPutStrLn stderr "syntax: :set prog <progname>")
1108 setGHCiState st{ editor = cmd }
1110 setPrompt value = do
1113 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1114 else setGHCiState st{ prompt = remQuotes value }
1116 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1120 do -- first, deal with the GHCi opts (+s, +t, etc.)
1121 let (plus_opts, minus_opts) = partition isPlus wds
1122 mapM_ setOpt plus_opts
1124 -- then, dynamic flags
1125 dflags <- getDynFlags
1126 let pkg_flags = packageFlags dflags
1127 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1129 if (not (null leftovers))
1130 then throwDyn (CmdLineError ("unrecognised flags: " ++
1134 new_pkgs <- setDynFlags dflags'
1136 -- if the package flags changed, we should reset the context
1137 -- and link the new packages.
1138 dflags <- getDynFlags
1139 when (packageFlags dflags /= pkg_flags) $ do
1140 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1141 session <- getSession
1142 io (GHC.setTargets session [])
1143 io (GHC.load session LoadAllTargets)
1144 io (linkPackages dflags new_pkgs)
1145 setContextAfterLoad session []
1149 unsetOptions :: String -> GHCi ()
1151 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1152 let opts = words str
1153 (minus_opts, rest1) = partition isMinus opts
1154 (plus_opts, rest2) = partition isPlus rest1
1156 if (not (null rest2))
1157 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1160 mapM_ unsetOpt plus_opts
1162 -- can't do GHC flags for now
1163 if (not (null minus_opts))
1164 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1167 isMinus ('-':s) = True
1170 isPlus ('+':s) = True
1174 = case strToGHCiOpt str of
1175 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1176 Just o -> setOption o
1179 = case strToGHCiOpt str of
1180 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1181 Just o -> unsetOption o
1183 strToGHCiOpt :: String -> (Maybe GHCiOption)
1184 strToGHCiOpt "s" = Just ShowTiming
1185 strToGHCiOpt "t" = Just ShowType
1186 strToGHCiOpt "r" = Just RevertCAFs
1187 strToGHCiOpt _ = Nothing
1189 optToStr :: GHCiOption -> String
1190 optToStr ShowTiming = "s"
1191 optToStr ShowType = "t"
1192 optToStr RevertCAFs = "r"
1194 -- ---------------------------------------------------------------------------
1199 ["modules" ] -> showModules
1200 ["bindings"] -> showBindings
1201 ["linker"] -> io showLinkerState
1202 ["breaks"] -> showBkptTable
1203 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1206 session <- getSession
1207 let show_one ms = do m <- io (GHC.showModule session ms)
1209 graph <- io (GHC.getModuleGraph session)
1210 mapM_ show_one graph
1214 unqual <- io (GHC.getPrintUnqual s)
1215 bindings <- io (GHC.getBindings s)
1216 mapM_ showTyThing bindings
1219 showTyThing (AnId id) = do
1220 ty' <- cleanType (GHC.idType id)
1221 printForUser $ ppr id <> text " :: " <> ppr ty'
1222 showTyThing _ = return ()
1224 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1225 cleanType :: Type -> GHCi Type
1227 dflags <- getDynFlags
1228 if dopt Opt_GlasgowExts dflags
1230 else return $! GHC.dropForAlls ty
1232 showBkptTable :: GHCi ()
1234 activeBreaks <- getActiveBreakPoints
1235 printForUser $ ppr activeBreaks
1237 -- -----------------------------------------------------------------------------
1240 completeNone :: String -> IO [String]
1241 completeNone w = return []
1244 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1245 completeWord w start end = do
1246 line <- Readline.getLineBuffer
1248 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1250 | Just c <- is_cmd line -> do
1251 maybe_cmd <- lookupCommand c
1252 let (n,w') = selectWord (words' 0 line)
1254 Nothing -> return Nothing
1255 Just (_,_,False,complete) -> wrapCompleter complete w
1256 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1257 return (map (drop n) rets)
1258 in wrapCompleter complete' w'
1260 --printf "complete %s, start = %d, end = %d\n" w start end
1261 wrapCompleter completeIdentifier w
1262 where words' _ [] = []
1263 words' n str = let (w,r) = break isSpace str
1264 (s,r') = span isSpace r
1265 in (n,w):words' (n+length w+length s) r'
1266 -- In a Haskell expression we want to parse 'a-b' as three words
1267 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1268 -- only be a single word.
1269 selectWord [] = (0,w)
1270 selectWord ((offset,x):xs)
1271 | offset+length x >= start = (start-offset,take (end-offset) x)
1272 | otherwise = selectWord xs
1275 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1276 | otherwise = Nothing
1279 cmds <- readIORef commands
1280 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1282 completeMacro w = do
1283 cmds <- readIORef commands
1284 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1285 return (filter (w `isPrefixOf`) cmds')
1287 completeIdentifier w = do
1289 rdrs <- GHC.getRdrNamesInScope s
1290 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1292 completeModule w = do
1294 dflags <- GHC.getSessionDynFlags s
1295 let pkg_mods = allExposedModules dflags
1296 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1298 completeHomeModule w = do
1300 g <- GHC.getModuleGraph s
1301 let home_mods = map GHC.ms_mod_name g
1302 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1304 completeSetOptions w = do
1305 return (filter (w `isPrefixOf`) options)
1306 where options = "args":"prog":allFlags
1308 completeFilename = Readline.filenameCompletionFunction
1310 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1312 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1313 unionComplete f1 f2 w = do
1318 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1319 wrapCompleter fun w = do
1322 [] -> return Nothing
1323 [x] -> return (Just (x,[]))
1324 xs -> case getCommonPrefix xs of
1325 "" -> return (Just ("",xs))
1326 pref -> return (Just (pref,xs))
1328 getCommonPrefix :: [String] -> String
1329 getCommonPrefix [] = ""
1330 getCommonPrefix (s:ss) = foldl common s ss
1331 where common s "" = ""
1333 common (c:cs) (d:ds)
1334 | c == d = c : common cs ds
1337 allExposedModules :: DynFlags -> [ModuleName]
1338 allExposedModules dflags
1339 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1341 pkg_db = pkgIdMap (pkgState dflags)
1343 completeCmd = completeNone
1344 completeMacro = completeNone
1345 completeIdentifier = completeNone
1346 completeModule = completeNone
1347 completeHomeModule = completeNone
1348 completeSetOptions = completeNone
1349 completeFilename = completeNone
1350 completeHomeModuleOrFile=completeNone
1351 completeBkpt = completeNone
1354 -- ---------------------------------------------------------------------------
1355 -- User code exception handling
1357 -- This is the exception handler for exceptions generated by the
1358 -- user's code and exceptions coming from children sessions;
1359 -- it normally just prints out the exception. The
1360 -- handler must be recursive, in case showing the exception causes
1361 -- more exceptions to be raised.
1363 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1364 -- raising another exception. We therefore don't put the recursive
1365 -- handler arond the flushing operation, so if stderr is closed
1366 -- GHCi will just die gracefully rather than going into an infinite loop.
1367 handler :: Exception -> GHCi Bool
1369 handler exception = do
1371 io installSignalHandlers
1372 ghciHandle handler (showException exception >> return False)
1374 showException (DynException dyn) =
1375 case fromDynamic dyn of
1376 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1377 Just Interrupted -> io (putStrLn "Interrupted.")
1378 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1379 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1380 Just other_ghc_ex -> io (print other_ghc_ex)
1382 showException other_exception
1383 = io (putStrLn ("*** Exception: " ++ show other_exception))
1385 -----------------------------------------------------------------------------
1386 -- recursive exception handlers
1388 -- Don't forget to unblock async exceptions in the handler, or if we're
1389 -- in an exception loop (eg. let a = error a in a) the ^C exception
1390 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1392 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1393 ghciHandle h (GHCi m) = GHCi $ \s ->
1394 Exception.catch (m s)
1395 (\e -> unGHCi (ghciUnblock (h e)) s)
1397 ghciUnblock :: GHCi a -> GHCi a
1398 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1401 -- ----------------------------------------------------------------------------
1404 expandPath :: String -> GHCi String
1406 case dropWhile isSpace path of
1408 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1409 return (tilde ++ '/':d)
1413 -- ----------------------------------------------------------------------------
1414 -- Windows console setup
1416 setUpConsole :: IO ()
1418 #ifdef mingw32_HOST_OS
1419 -- On Windows we need to set a known code page, otherwise the characters
1420 -- we read from the console will be be in some strange encoding, and
1421 -- similarly for characters we write to the console.
1423 -- At the moment, GHCi pretends all input is Latin-1. In the
1424 -- future we should support UTF-8, but for now we set the code pages
1427 -- It seems you have to set the font in the console window to
1428 -- a Unicode font in order for output to work properly,
1429 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1430 -- (see MSDN for SetConsoleOutputCP()).
1432 setConsoleCP 28591 -- ISO Latin-1
1433 setConsoleOutputCP 28591 -- ISO Latin-1
1437 -- commands for debugger
1438 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1440 stepCmd :: String -> GHCi Bool
1441 stepCmd [] = doContinue setStepFlag
1442 stepCmd expression = do
1444 runCommand expression
1446 continueCmd :: String -> GHCi Bool
1447 continueCmd [] = doContinue $ return ()
1448 continueCmd other = do
1449 io $ putStrLn "The continue command accepts no arguments."
1452 doContinue :: IO () -> GHCi Bool
1453 doContinue actionBeforeCont = do
1454 resumeAction <- popResume
1455 case resumeAction of
1457 io $ putStrLn "There is no computation running."
1459 Just (_,_,handle) -> do
1460 io $ actionBeforeCont
1461 session <- getSession
1462 runResult <- io $ GHC.resume session handle
1463 names <- switchOnRunResult runResult
1464 finishEvalExpr names
1467 deleteCmd :: String -> GHCi Bool
1468 deleteCmd argLine = do
1469 deleteSwitch $ words argLine
1472 deleteSwitch :: [String] -> GHCi ()
1474 io $ putStrLn "The delete command requires at least one argument."
1475 -- delete all break points
1476 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1477 deleteSwitch idents = do
1478 mapM_ deleteOneBreak idents
1480 deleteOneBreak :: String -> GHCi ()
1482 | all isDigit str = deleteBreak (read str)
1483 | otherwise = return ()
1485 -- handle the "break" command
1486 breakCmd :: String -> GHCi Bool
1487 breakCmd argLine = do
1488 session <- getSession
1489 breakSwitch session $ words argLine
1491 breakSwitch :: Session -> [String] -> GHCi Bool
1492 breakSwitch _session [] = do
1493 io $ putStrLn "The break command requires at least one argument."
1495 breakSwitch session args@(arg1:rest)
1496 | looksLikeModule arg1 = do
1497 mod <- wantInterpretedModule session arg1
1498 breakByModule mod rest
1501 (toplevel, _) <- io $ GHC.getContext session
1503 (mod : _) -> breakByModule mod args
1505 io $ putStrLn "Cannot find default module for breakpoint."
1506 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1509 -- Todo there may be a nicer way to test this
1510 looksLikeModule :: String -> Bool
1511 looksLikeModule [] = False
1512 looksLikeModule (x:_) = isUpper x
1514 wantInterpretedModule :: Session -> String -> GHCi Module
1515 wantInterpretedModule session str = do
1516 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1517 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1518 when (not is_interpreted) $
1519 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1522 breakByModule :: Module -> [String] -> GHCi ()
1523 breakByModule mod args@(arg1:rest)
1524 | all isDigit arg1 = do -- looks like a line number
1525 breakByModuleLine mod (read arg1) rest
1526 | looksLikeVar arg1 = do
1527 -- break by a function definition
1528 io $ putStrLn "Break by function definition not implemented."
1529 | otherwise = io $ putStrLn "Invalid arguments to break command."
1531 -- Todo there may be a nicer way to test this
1532 looksLikeVar :: String -> Bool
1533 looksLikeVar [] = False
1534 looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
1536 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1537 breakByModuleLine mod line args
1538 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1539 | [col] <- args, all isDigit col =
1540 findBreakAndSet mod $ findBreakByCoord (line, read col)
1541 | otherwise = io $ putStrLn "Invalid arguments to break command."
1543 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1544 findBreakAndSet mod lookupTickTree = do
1545 tickArray <- getTickArray mod
1546 (breakArray, _) <- getModBreak mod
1547 case lookupTickTree tickArray of
1548 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1549 Just (tick, span) -> do
1550 success <- io $ setBreakFlag True breakArray tick
1551 session <- getSession
1555 recordBreak $ BreakLocation
1561 text "Breakpoint " <> ppr nm <>
1563 then text " was already set at " <> ppr span
1564 else text " activated at " <> ppr span
1566 printForUser $ text "Breakpoint could not be activated at"
1569 -- When a line number is specified, the current policy for choosing
1570 -- the best breakpoint is this:
1571 -- - the leftmost complete subexpression on the specified line, or
1572 -- - the leftmost subexpression starting on the specified line, or
1573 -- - the rightmost subexpression enclosing the specified line
1575 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1576 findBreakByLine line arr =
1577 listToMaybe (sortBy leftmost complete) `mplus`
1578 listToMaybe (sortBy leftmost incomplete) `mplus`
1579 listToMaybe (sortBy rightmost ticks)
1583 starts_here = [ tick | tick@(nm,span) <- ticks,
1584 srcSpanStartLine span == line ]
1586 (complete,incomplete) = partition ends_here starts_here
1587 where ends_here (nm,span) = srcSpanEndLine span == line
1589 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1590 findBreakByCoord (line, col) arr =
1591 listToMaybe (sortBy rightmost contains)
1595 -- the ticks that span this coordinate
1596 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1598 leftmost (_,a) (_,b) = a `compare` b
1599 rightmost (_,a) (_,b) = b `compare` a
1601 spans :: SrcSpan -> (Int,Int) -> Bool
1602 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1603 where loc = mkSrcLoc (srcSpanFile span) l c
1606 -- --------------------------------------------------------------------------
1609 getTickArray :: Module -> GHCi TickArray
1610 getTickArray modl = do
1612 let arrmap = tickarrays st
1613 case lookupModuleEnv arrmap modl of
1614 Just arr -> return arr
1616 (breakArray, ticks) <- getModBreak modl
1617 let arr = mkTickArray (assocs ticks)
1618 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1621 discardTickArrays :: GHCi ()
1622 discardTickArrays = do
1624 setGHCiState st{tickarrays = emptyModuleEnv}
1626 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1628 = accumArray (flip (:)) [] (1, max_line)
1629 [ (line, (nm,span)) | (nm,span) <- ticks,
1630 line <- srcSpanLines span ]
1632 max_line = maximum (map srcSpanEndLine (map snd ticks))
1633 srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1635 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
1636 getModBreak mod = do
1637 session <- getSession
1638 Just mod_info <- io $ GHC.getModuleInfo session mod
1639 let modBreaks = GHC.modInfoModBreaks mod_info
1640 let array = GHC.modBreaks_flags modBreaks
1641 let ticks = GHC.modBreaks_locs modBreaks
1642 return (array, ticks)
1644 lookupModule :: Session -> String -> GHCi Module
1645 lookupModule session modName
1646 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1648 setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
1649 setBreakFlag toggle array index
1650 | toggle = setBreakOn array index
1651 | otherwise = setBreakOff array index
1654 {- these should probably go to the GHC API at some point -}
1655 enableBreakPoint :: Session -> Module -> Int -> IO ()
1656 enableBreakPoint session mod index = return ()
1658 disableBreakPoint :: Session -> Module -> Int -> IO ()
1659 disableBreakPoint session mod index = return ()
1661 activeBreakPoints :: Session -> IO [(Module,Int)]
1662 activeBreakPoints session = return []
1664 enableSingleStep :: Session -> IO ()
1665 enableSingleStep session = return ()
1667 disableSingleStep :: Session -> IO ()
1668 disableSingleStep session = return ()