1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
21 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
22 Type, Module, ModuleName, TyThing(..), Phase,
23 BreakIndex, Name, SrcSpan )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
37 import FastString ( unpackFS )
43 #ifndef mingw32_HOST_OS
45 #if __GLASGOW_HASKELL__ > 504
49 import GHC.ConsoleHandler ( flushConsole )
50 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
51 import qualified System.Win32
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
62 -- import Control.Concurrent
64 import qualified Data.ByteString.Char8 as BS
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
76 import Control.Monad as Monad
78 import Foreign.StablePtr ( newStablePtr )
79 import GHC.Exts ( unsafeCoerce# )
80 import GHC.IOBase ( IOErrorType(InvalidArgument) )
82 import Data.IORef ( IORef, readIORef, writeIORef )
84 import System.Posix.Internals ( setNonBlockingFD )
86 -----------------------------------------------------------------------------
90 " / _ \\ /\\ /\\/ __(_)\n"++
91 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
92 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
93 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
95 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
98 GLOBAL_VAR(commands, builtin_commands, [Command])
100 builtin_commands :: [Command]
102 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
103 ("?", keepGoing help, False, completeNone),
104 ("add", keepGoingPaths addModule, False, completeFilename),
105 ("abandon", keepGoing abandonCmd, False, completeNone),
106 ("break", keepGoing breakCmd, False, completeIdentifier),
107 ("browse", keepGoing browseCmd, False, completeModule),
108 ("cd", keepGoing changeDirectory, False, completeFilename),
109 ("check", keepGoing checkModule, False, completeHomeModule),
110 ("continue", continueCmd, False, completeNone),
111 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
112 ("def", keepGoing defineMacro, False, completeIdentifier),
113 ("delete", keepGoing deleteCmd, False, completeNone),
114 ("e", keepGoing editFile, False, completeFilename),
115 ("edit", keepGoing editFile, False, completeFilename),
116 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
117 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
118 ("help", keepGoing help, False, completeNone),
119 ("info", keepGoing info, False, completeIdentifier),
120 ("kind", keepGoing kindOfType, False, completeIdentifier),
121 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
122 ("list", keepGoing listCmd, False, completeNone),
123 ("module", keepGoing setContext, False, completeModule),
124 ("main", keepGoing runMain, False, completeIdentifier),
125 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
126 ("quit", quit, False, completeNone),
127 ("reload", keepGoing reloadModule, False, completeNone),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
131 ("step", stepCmd, False, completeIdentifier),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("undef", keepGoing undefineMacro, False, completeMacro),
134 ("unset", keepGoing unsetOptions, True, completeSetOptions)
137 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
138 keepGoing a str = a str >> return False
140 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoingPaths a str = a (toArgs str) >> return False
143 shortHelpText = "use :? for help.\n"
146 " Commands available from the prompt:\n" ++
148 " <stmt> evaluate/run <stmt>\n" ++
149 " :add <filename> ... add module(s) to the current target set\n" ++
150 " :abandon at a breakpoint, abandon current computation\n" ++
151 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
152 " :break <name> set a breakpoint on the specified function\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :continue resume after a breakpoint\n" ++
156 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :delete <number> delete the specified breakpoint\n" ++
159 " :delete * delete all breakpoints\n" ++
160 " :edit <file> edit file\n" ++
161 " :edit edit last module\n" ++
162 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
163 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
164 " :help, :? display this list of commands\n" ++
165 " :info [<name> ...] display information about the given names\n" ++
166 " :kind <type> show the kind of <type>\n" ++
167 " :load <filename> ... load module(s) and their dependents\n" ++
168 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
169 " :main [<arguments> ...] run the main function with the given arguments\n" ++
170 " :print [<name> ...] prints a value without forcing its computation\n" ++
171 " :quit exit GHCi\n" ++
172 " :reload reload the current module set\n" ++
174 " :set <option> ... set options\n" ++
175 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
176 " :set prog <progname> set the value returned by System.getProgName\n" ++
177 " :set prompt <prompt> set the prompt used in GHCi\n" ++
178 " :set editor <cmd> set the command used for :edit\n" ++
179 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
181 " :show breaks show active breakpoints\n" ++
182 " :show context show the breakpoint context\n" ++
183 " :show modules show the currently loaded modules\n" ++
184 " :show bindings show the current bindings made at the prompt\n" ++
186 " :sprint [<name> ...] simplifed version of :print\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :type <expr> show the type of <expr>\n" ++
190 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
191 " :unset <option> ... unset options\n" ++
192 " :!<command> run the shell command <command>\n" ++
194 " Options for ':set' and ':unset':\n" ++
196 " +r revert top-level expressions after each evaluation\n" ++
197 " +s print timing/memory stats after each evaluation\n" ++
198 " +t print type after evaluation\n" ++
199 " -<flags> most GHC command line flags can also be set here\n" ++
200 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
202 -- Todo: add help for breakpoint commands here
208 win <- System.Win32.getWindowsDirectory
209 return (win `joinFileName` "notepad.exe")
214 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
215 interactiveUI session srcs maybe_expr = do
216 -- HACK! If we happen to get into an infinite loop (eg the user
217 -- types 'let x=x in x' at the prompt), then the thread will block
218 -- on a blackhole, and become unreachable during GC. The GC will
219 -- detect that it is unreachable and send it the NonTermination
220 -- exception. However, since the thread is unreachable, everything
221 -- it refers to might be finalized, including the standard Handles.
222 -- This sounds like a bug, but we don't have a good solution right
228 -- Initialise buffering for the *interpreted* I/O system
229 initInterpBuffering session
231 when (isNothing maybe_expr) $ do
232 -- Only for GHCi (not runghc and ghc -e):
233 -- Turn buffering off for the compiled program's stdout/stderr
235 -- Turn buffering off for GHCi's stdout
237 hSetBuffering stdout NoBuffering
238 -- We don't want the cmd line to buffer any input that might be
239 -- intended for the program, so unbuffer stdin.
240 hSetBuffering stdin NoBuffering
242 -- initial context is just the Prelude
243 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
244 GHC.setContext session [] [prel_mod]
248 Readline.setAttemptedCompletionFunction (Just completeWord)
249 --Readline.parseAndBind "set show-all-if-ambiguous 1"
251 let symbols = "!#$%&*+/<=>?@\\^|-~"
252 specials = "(),;[]`{}"
254 word_break_chars = spaces ++ specials ++ symbols
256 Readline.setBasicWordBreakCharacters word_break_chars
257 Readline.setCompleterWordBreakCharacters word_break_chars
260 default_editor <- findEditor
262 startGHCi (runGHCi srcs maybe_expr)
263 GHCiState{ progname = "<interactive>",
267 editor = default_editor,
272 breaks = emptyActiveBreakPoints,
273 tickarrays = emptyModuleEnv
277 Readline.resetTerminal Nothing
282 prel_name = GHC.mkModuleName "Prelude"
284 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
285 runGHCi paths maybe_expr = do
286 let read_dot_files = not opt_IgnoreDotGhci
288 when (read_dot_files) $ do
291 exists <- io (doesFileExist file)
293 dir_ok <- io (checkPerms ".")
294 file_ok <- io (checkPerms file)
295 when (dir_ok && file_ok) $ do
296 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
299 Right hdl -> fileLoop hdl False
301 when (read_dot_files) $ do
302 -- Read in $HOME/.ghci
303 either_dir <- io (IO.try (getEnv "HOME"))
307 cwd <- io (getCurrentDirectory)
308 when (dir /= cwd) $ do
309 let file = dir ++ "/.ghci"
310 ok <- io (checkPerms file)
312 either_hdl <- io (IO.try (openFile file ReadMode))
315 Right hdl -> fileLoop hdl False
317 -- Perform a :load for files given on the GHCi command line
318 -- When in -e mode, if the load fails then we want to stop
319 -- immediately rather than going on to evaluate the expression.
320 when (not (null paths)) $ do
321 ok <- ghciHandle (\e -> do showException e; return Failed) $
323 when (isJust maybe_expr && failed ok) $
324 io (exitWith (ExitFailure 1))
326 -- if verbosity is greater than 0, or we are connected to a
327 -- terminal, display the prompt in the interactive loop.
328 is_tty <- io (hIsTerminalDevice stdin)
329 dflags <- getDynFlags
330 let show_prompt = verbosity dflags > 0 || is_tty
335 #if defined(mingw32_HOST_OS)
336 -- The win32 Console API mutates the first character of
337 -- type-ahead when reading from it in a non-buffered manner. Work
338 -- around this by flushing the input buffer of type-ahead characters,
339 -- but only if stdin is available.
340 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
342 Left err | isDoesNotExistError err -> return ()
343 | otherwise -> io (ioError err)
344 Right () -> return ()
346 -- initialise the console if necessary
349 -- enter the interactive loop
350 interactiveLoop is_tty show_prompt
352 -- just evaluate the expression we were given
357 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
360 interactiveLoop is_tty show_prompt =
361 -- Ignore ^C exceptions caught here
362 ghciHandleDyn (\e -> case e of
364 #if defined(mingw32_HOST_OS)
367 interactiveLoop is_tty show_prompt
368 _other -> return ()) $
370 ghciUnblock $ do -- unblock necessary if we recursed from the
371 -- exception handler above.
373 -- read commands from stdin
377 else fileLoop stdin show_prompt
379 fileLoop stdin show_prompt
383 -- NOTE: We only read .ghci files if they are owned by the current user,
384 -- and aren't world writable. Otherwise, we could be accidentally
385 -- running code planted by a malicious third party.
387 -- Furthermore, We only read ./.ghci if . is owned by the current user
388 -- and isn't writable by anyone else. I think this is sufficient: we
389 -- don't need to check .. and ../.. etc. because "." always refers to
390 -- the same directory while a process is running.
392 checkPerms :: String -> IO Bool
394 #ifdef mingw32_HOST_OS
397 Util.handle (\_ -> return False) $ do
398 st <- getFileStatus name
400 if fileOwner st /= me then do
401 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
404 let mode = fileMode st
405 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
406 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
408 putStrLn $ "*** WARNING: " ++ name ++
409 " is writable by someone else, IGNORING!"
414 fileLoop :: Handle -> Bool -> GHCi ()
415 fileLoop hdl show_prompt = do
416 session <- getSession
417 (mod,imports) <- io (GHC.getContext session)
419 when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st))))
420 l <- io (IO.try (hGetLine hdl))
422 Left e | isEOFError e -> return ()
423 | InvalidArgument <- etype -> return ()
424 | otherwise -> io (ioError e)
425 where etype = ioeGetErrorType e
426 -- treat InvalidArgument in the same way as EOF:
427 -- this can happen if the user closed stdin, or
428 -- perhaps did getContents which closes stdin at
431 case removeSpaces l of
432 "" -> fileLoop hdl show_prompt
433 l -> do quit <- runCommand l
434 if quit then return () else fileLoop hdl show_prompt
436 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
437 stringLoop [] = return False
438 stringLoop (s:ss) = do
439 case removeSpaces s of
441 l -> do quit <- runCommand l
442 if quit then return True else stringLoop ss
444 mkPrompt toplevs exports resumes prompt
445 = showSDoc $ f prompt
447 f ('%':'s':xs) = perc_s <> f xs
448 f ('%':'%':xs) = char '%' <> f xs
449 f (x:xs) = char x <> f xs
453 | (span,_,_):rest <- resumes
454 = (if not (null rest) then text "... " else empty)
455 <> brackets (ppr span) <+> modules_prompt
460 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
461 hsep (map (ppr . GHC.moduleName) exports)
466 readlineLoop :: GHCi ()
468 session <- getSession
469 (mod,imports) <- io (GHC.getContext session)
471 saveSession -- for use by completion
473 l <- io (readline (mkPrompt mod imports (resume st) (prompt st))
474 `finally` setNonBlockingFD 0)
475 -- readline sometimes puts stdin into blocking mode,
476 -- so we need to put it back for the IO library
481 case removeSpaces l of
486 if quit then return () else readlineLoop
489 runCommand :: String -> GHCi Bool
490 runCommand c = ghciHandle handler (doCommand c)
492 doCommand (':' : command) = specialCommand command
494 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
497 -- This version is for the GHC command-line option -e. The only difference
498 -- from runCommand is that it catches the ExitException exception and
499 -- exits, rather than printing out the exception.
500 runCommandEval c = ghciHandle handleEval (doCommand c)
502 handleEval (ExitException code) = io (exitWith code)
503 handleEval e = do handler e
504 io (exitWith (ExitFailure 1))
506 doCommand (':' : command) = specialCommand command
508 = do nms <- runStmt stmt
510 Nothing -> io (exitWith (ExitFailure 1))
511 -- failure to run the command causes exit(1) for ghc -e.
512 _ -> do finishEvalExpr nms
515 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
517 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
519 = do st <- getGHCiState
520 session <- getSession
521 result <- io $ withProgName (progname st) $ withArgs (args st) $
522 GHC.runStmt session stmt
523 switchOnRunResult result
525 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
526 switchOnRunResult GHC.RunFailed = return Nothing
527 switchOnRunResult (GHC.RunException e) = throw e
528 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
529 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
530 session <- getSession
531 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
532 let modBreaks = GHC.modInfoModBreaks mod_info
533 let ticks = GHC.modBreaks_locs modBreaks
535 -- display information about the breakpoint
536 let location = ticks ! GHC.breakInfo_number info
537 printForUser $ ptext SLIT("Stopped at") <+> ppr location
539 pushResume location threadId resume
541 -- run the command set with ":set stop <cmd>"
545 return (Just (True,names))
547 -- possibly print the type and revert CAFs after evaluating an expression
548 finishEvalExpr mb_names
549 = do show_types <- isOptionSet ShowType
550 session <- getSession
553 Just (is_break,names) ->
554 when (is_break || show_types) $
555 mapM_ (showTypeOfName session) names
558 io installSignalHandlers
559 b <- isOptionSet RevertCAFs
560 io (when b revertCAFs)
562 showTypeOfName :: Session -> Name -> GHCi ()
563 showTypeOfName session n
564 = do maybe_tything <- io (GHC.lookupName session n)
565 case maybe_tything of
567 Just thing -> showTyThing thing
569 specialCommand :: String -> GHCi Bool
570 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
571 specialCommand str = do
572 let (cmd,rest) = break isSpace str
573 maybe_cmd <- io (lookupCommand cmd)
575 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
576 ++ shortHelpText) >> return False)
577 Just (_,f,_,_) -> f (dropWhile isSpace rest)
579 lookupCommand :: String -> IO (Maybe Command)
580 lookupCommand str = do
581 cmds <- readIORef commands
582 -- look for exact match first, then the first prefix match
583 case [ c | c <- cmds, str == cmdName c ] of
584 c:_ -> return (Just c)
585 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
587 c:_ -> return (Just c)
589 -----------------------------------------------------------------------------
592 help :: String -> GHCi ()
593 help _ = io (putStr helpText)
595 info :: String -> GHCi ()
596 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
597 info s = do { let names = words s
598 ; session <- getSession
599 ; dflags <- getDynFlags
600 ; let exts = dopt Opt_GlasgowExts dflags
601 ; mapM_ (infoThing exts session) names }
603 infoThing exts session str = io $ do
604 names <- GHC.parseName session str
605 let filtered = filterOutChildren names
606 mb_stuffs <- mapM (GHC.getInfo session) filtered
607 unqual <- GHC.getPrintUnqual session
608 putStrLn (showSDocForUser unqual $
609 vcat (intersperse (text "") $
610 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
612 -- Filter out names whose parent is also there Good
613 -- example is '[]', which is both a type and data
614 -- constructor in the same type
615 filterOutChildren :: [Name] -> [Name]
616 filterOutChildren names = filter (not . parent_is_there) names
617 where parent_is_there n
618 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
622 pprInfo exts (thing, fixity, insts)
623 = pprTyThingInContextLoc exts thing
624 $$ show_fixity fixity
625 $$ vcat (map GHC.pprInstance insts)
628 | fix == GHC.defaultFixity = empty
629 | otherwise = ppr fix <+> ppr (GHC.getName thing)
631 runMain :: String -> GHCi ()
633 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
634 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
637 addModule :: [FilePath] -> GHCi ()
639 io (revertCAFs) -- always revert CAFs on load/add.
640 files <- mapM expandPath files
641 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
642 session <- getSession
643 io (mapM_ (GHC.addTarget session) targets)
644 ok <- io (GHC.load session LoadAllTargets)
647 changeDirectory :: String -> GHCi ()
648 changeDirectory dir = do
649 session <- getSession
650 graph <- io (GHC.getModuleGraph session)
651 when (not (null graph)) $
652 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
653 io (GHC.setTargets session [])
654 io (GHC.load session LoadAllTargets)
655 setContextAfterLoad session []
656 io (GHC.workingDirectoryChanged session)
657 dir <- expandPath dir
658 io (setCurrentDirectory dir)
660 editFile :: String -> GHCi ()
663 -- find the name of the "topmost" file loaded
664 session <- getSession
665 graph0 <- io (GHC.getModuleGraph session)
666 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
667 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
668 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
669 Just file -> do_edit file
670 Nothing -> throwDyn (CmdLineError "unknown file name")
671 | otherwise = do_edit str
677 throwDyn (CmdLineError "editor not set, use :set editor")
678 io $ system (cmd ++ ' ':file)
681 defineMacro :: String -> GHCi ()
683 let (macro_name, definition) = break isSpace s
684 cmds <- io (readIORef commands)
686 then throwDyn (CmdLineError "invalid macro name")
688 if (macro_name `elem` map cmdName cmds)
689 then throwDyn (CmdLineError
690 ("command '" ++ macro_name ++ "' is already defined"))
693 -- give the expression a type signature, so we can be sure we're getting
694 -- something of the right type.
695 let new_expr = '(' : definition ++ ") :: String -> IO String"
697 -- compile the expression
699 maybe_hv <- io (GHC.compileExpr cms new_expr)
702 Just hv -> io (writeIORef commands --
703 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
705 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
707 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
708 stringLoop (lines str)
710 undefineMacro :: String -> GHCi ()
711 undefineMacro macro_name = do
712 cmds <- io (readIORef commands)
713 if (macro_name `elem` map cmdName builtin_commands)
714 then throwDyn (CmdLineError
715 ("command '" ++ macro_name ++ "' cannot be undefined"))
717 if (macro_name `notElem` map cmdName cmds)
718 then throwDyn (CmdLineError
719 ("command '" ++ macro_name ++ "' not defined"))
721 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
724 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
725 loadModule fs = timeIt (loadModule' fs)
727 loadModule_ :: [FilePath] -> GHCi ()
728 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
730 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
731 loadModule' files = do
732 session <- getSession
735 io (GHC.setTargets session [])
736 io (GHC.load session LoadAllTargets)
739 let (filenames, phases) = unzip files
740 exp_filenames <- mapM expandPath filenames
741 let files' = zip exp_filenames phases
742 targets <- io (mapM (uncurry GHC.guessTarget) files')
744 -- NOTE: we used to do the dependency anal first, so that if it
745 -- fails we didn't throw away the current set of modules. This would
746 -- require some re-working of the GHC interface, so we'll leave it
747 -- as a ToDo for now.
749 io (GHC.setTargets session targets)
750 ok <- io (GHC.load session LoadAllTargets)
754 checkModule :: String -> GHCi ()
756 let modl = GHC.mkModuleName m
757 session <- getSession
758 result <- io (GHC.checkModule session modl)
760 Nothing -> io $ putStrLn "Nothing"
761 Just r -> io $ putStrLn (showSDoc (
762 case GHC.checkedModuleInfo r of
763 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
765 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
767 (text "global names: " <+> ppr global) $$
768 (text "local names: " <+> ppr local)
770 afterLoad (successIf (isJust result)) session
772 reloadModule :: String -> GHCi ()
774 io (revertCAFs) -- always revert CAFs on reload.
775 session <- getSession
776 ok <- io (GHC.load session LoadAllTargets)
779 io (revertCAFs) -- always revert CAFs on reload.
780 session <- getSession
781 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
784 afterLoad ok session = do
785 io (revertCAFs) -- always revert CAFs on load.
788 discardActiveBreakPoints
789 graph <- io (GHC.getModuleGraph session)
790 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
791 setContextAfterLoad session graph'
792 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
794 setContextAfterLoad session [] = do
795 prel_mod <- getPrelude
796 io (GHC.setContext session [] [prel_mod])
797 setContextAfterLoad session ms = do
798 -- load a target if one is available, otherwise load the topmost module.
799 targets <- io (GHC.getTargets session)
800 case [ m | Just m <- map (findTarget ms) targets ] of
802 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
803 load_this (last graph')
808 = case filter (`matches` t) ms of
812 summary `matches` Target (TargetModule m) _
813 = GHC.ms_mod_name summary == m
814 summary `matches` Target (TargetFile f _) _
815 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
816 summary `matches` target
819 load_this summary | m <- GHC.ms_mod summary = do
820 b <- io (GHC.moduleIsInterpreted session m)
821 if b then io (GHC.setContext session [m] [])
823 prel_mod <- getPrelude
824 io (GHC.setContext session [] [prel_mod,m])
827 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
828 modulesLoadedMsg ok mods = do
829 dflags <- getDynFlags
830 when (verbosity dflags > 0) $ do
832 | null mods = text "none."
834 punctuate comma (map ppr mods)) <> text "."
837 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
839 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
842 typeOfExpr :: String -> GHCi ()
844 = do cms <- getSession
845 maybe_ty <- io (GHC.exprType cms str)
848 Just ty -> do ty' <- cleanType ty
849 printForUser $ text str <> text " :: " <> ppr ty'
851 kindOfType :: String -> GHCi ()
853 = do cms <- getSession
854 maybe_ty <- io (GHC.typeKind cms str)
857 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
859 quit :: String -> GHCi Bool
862 shellEscape :: String -> GHCi Bool
863 shellEscape str = io (system str >> return False)
865 -----------------------------------------------------------------------------
866 -- Browsing a module's contents
868 browseCmd :: String -> GHCi ()
871 ['*':m] | looksLikeModuleName m -> browseModule m False
872 [m] | looksLikeModuleName m -> browseModule m True
873 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
875 browseModule m exports_only = do
877 modl <- if exports_only then lookupModule s m
878 else wantInterpretedModule s m
880 -- Temporarily set the context to the module we're interested in,
881 -- just so we can get an appropriate PrintUnqualified
882 (as,bs) <- io (GHC.getContext s)
883 prel_mod <- getPrelude
884 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
885 else GHC.setContext s [modl] [])
886 unqual <- io (GHC.getPrintUnqual s)
887 io (GHC.setContext s as bs)
889 mb_mod_info <- io $ GHC.getModuleInfo s modl
891 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
894 | exports_only = GHC.modInfoExports mod_info
895 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
897 filtered = filterOutChildren names
899 things <- io $ mapM (GHC.lookupName s) filtered
901 dflags <- getDynFlags
902 let exts = dopt Opt_GlasgowExts dflags
903 io (putStrLn (showSDocForUser unqual (
904 vcat (map (pprTyThingInContext exts) (catMaybes things))
906 -- ToDo: modInfoInstances currently throws an exception for
907 -- package modules. When it works, we can do this:
908 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
910 -----------------------------------------------------------------------------
911 -- Setting the module context
914 | all sensible mods = fn mods
915 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
917 (fn, mods) = case str of
918 '+':stuff -> (addToContext, words stuff)
919 '-':stuff -> (removeFromContext, words stuff)
920 stuff -> (newContext, words stuff)
922 sensible ('*':m) = looksLikeModuleName m
923 sensible m = looksLikeModuleName m
925 separate :: Session -> [String] -> [Module] -> [Module]
926 -> GHCi ([Module],[Module])
927 separate session [] as bs = return (as,bs)
928 separate session (('*':str):ms) as bs = do
929 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
930 b <- io $ GHC.moduleIsInterpreted session m
931 if b then separate session ms (m:as) bs
932 else throwDyn (CmdLineError ("module '"
933 ++ GHC.moduleNameString (GHC.moduleName m)
934 ++ "' is not interpreted"))
935 separate session (str:ms) as bs = do
936 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
937 separate session ms as (m:bs)
939 newContext :: [String] -> GHCi ()
942 (as,bs) <- separate s strs [] []
943 prel_mod <- getPrelude
944 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
945 io $ GHC.setContext s as bs'
948 addToContext :: [String] -> GHCi ()
949 addToContext strs = do
951 (as,bs) <- io $ GHC.getContext s
953 (new_as,new_bs) <- separate s strs [] []
955 let as_to_add = new_as \\ (as ++ bs)
956 bs_to_add = new_bs \\ (as ++ bs)
958 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
961 removeFromContext :: [String] -> GHCi ()
962 removeFromContext strs = do
964 (as,bs) <- io $ GHC.getContext s
966 (as_to_remove,bs_to_remove) <- separate s strs [] []
968 let as' = as \\ (as_to_remove ++ bs_to_remove)
969 bs' = bs \\ (as_to_remove ++ bs_to_remove)
971 io $ GHC.setContext s as' bs'
973 ----------------------------------------------------------------------------
976 -- set options in the interpreter. Syntax is exactly the same as the
977 -- ghc command line, except that certain options aren't available (-C,
980 -- This is pretty fragile: most options won't work as expected. ToDo:
981 -- figure out which ones & disallow them.
983 setCmd :: String -> GHCi ()
985 = do st <- getGHCiState
986 let opts = options st
987 io $ putStrLn (showSDoc (
988 text "options currently set: " <>
991 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
995 ("args":args) -> setArgs args
996 ("prog":prog) -> setProg prog
997 ("prompt":prompt) -> setPrompt (after 6)
998 ("editor":cmd) -> setEditor (after 6)
999 ("stop":cmd) -> setStop (after 4)
1000 wds -> setOptions wds
1001 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1005 setGHCiState st{ args = args }
1009 setGHCiState st{ progname = prog }
1011 io (hPutStrLn stderr "syntax: :set prog <progname>")
1015 setGHCiState st{ editor = cmd }
1019 setGHCiState st{ stop = cmd }
1021 setPrompt value = do
1024 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1025 else setGHCiState st{ prompt = remQuotes value }
1027 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1031 do -- first, deal with the GHCi opts (+s, +t, etc.)
1032 let (plus_opts, minus_opts) = partition isPlus wds
1033 mapM_ setOpt plus_opts
1035 -- then, dynamic flags
1036 dflags <- getDynFlags
1037 let pkg_flags = packageFlags dflags
1038 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1040 if (not (null leftovers))
1041 then throwDyn (CmdLineError ("unrecognised flags: " ++
1045 new_pkgs <- setDynFlags dflags'
1047 -- if the package flags changed, we should reset the context
1048 -- and link the new packages.
1049 dflags <- getDynFlags
1050 when (packageFlags dflags /= pkg_flags) $ do
1051 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1052 session <- getSession
1053 io (GHC.setTargets session [])
1054 io (GHC.load session LoadAllTargets)
1055 io (linkPackages dflags new_pkgs)
1056 setContextAfterLoad session []
1060 unsetOptions :: String -> GHCi ()
1062 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1063 let opts = words str
1064 (minus_opts, rest1) = partition isMinus opts
1065 (plus_opts, rest2) = partition isPlus rest1
1067 if (not (null rest2))
1068 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1071 mapM_ unsetOpt plus_opts
1073 -- can't do GHC flags for now
1074 if (not (null minus_opts))
1075 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1078 isMinus ('-':s) = True
1081 isPlus ('+':s) = True
1085 = case strToGHCiOpt str of
1086 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1087 Just o -> setOption o
1090 = case strToGHCiOpt str of
1091 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1092 Just o -> unsetOption o
1094 strToGHCiOpt :: String -> (Maybe GHCiOption)
1095 strToGHCiOpt "s" = Just ShowTiming
1096 strToGHCiOpt "t" = Just ShowType
1097 strToGHCiOpt "r" = Just RevertCAFs
1098 strToGHCiOpt _ = Nothing
1100 optToStr :: GHCiOption -> String
1101 optToStr ShowTiming = "s"
1102 optToStr ShowType = "t"
1103 optToStr RevertCAFs = "r"
1105 -- ---------------------------------------------------------------------------
1110 ["modules" ] -> showModules
1111 ["bindings"] -> showBindings
1112 ["linker"] -> io showLinkerState
1113 ["breaks"] -> showBkptTable
1114 ["context"] -> showContext
1115 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1118 session <- getSession
1119 let show_one ms = do m <- io (GHC.showModule session ms)
1121 graph <- io (GHC.getModuleGraph session)
1122 mapM_ show_one graph
1126 unqual <- io (GHC.getPrintUnqual s)
1127 bindings <- io (GHC.getBindings s)
1128 mapM_ showTyThing bindings
1131 showTyThing (AnId id) = do
1132 ty' <- cleanType (GHC.idType id)
1133 printForUser $ ppr id <> text " :: " <> ppr ty'
1134 showTyThing _ = return ()
1136 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1137 cleanType :: Type -> GHCi Type
1139 dflags <- getDynFlags
1140 if dopt Opt_GlasgowExts dflags
1142 else return $! GHC.dropForAlls ty
1144 showBkptTable :: GHCi ()
1146 activeBreaks <- getActiveBreakPoints
1147 printForUser $ ppr activeBreaks
1149 showContext :: GHCi ()
1152 printForUser $ vcat (map pp_resume (resume st))
1154 pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1156 -- -----------------------------------------------------------------------------
1159 completeNone :: String -> IO [String]
1160 completeNone w = return []
1163 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1164 completeWord w start end = do
1165 line <- Readline.getLineBuffer
1167 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1169 | Just c <- is_cmd line -> do
1170 maybe_cmd <- lookupCommand c
1171 let (n,w') = selectWord (words' 0 line)
1173 Nothing -> return Nothing
1174 Just (_,_,False,complete) -> wrapCompleter complete w
1175 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1176 return (map (drop n) rets)
1177 in wrapCompleter complete' w'
1179 --printf "complete %s, start = %d, end = %d\n" w start end
1180 wrapCompleter completeIdentifier w
1181 where words' _ [] = []
1182 words' n str = let (w,r) = break isSpace str
1183 (s,r') = span isSpace r
1184 in (n,w):words' (n+length w+length s) r'
1185 -- In a Haskell expression we want to parse 'a-b' as three words
1186 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1187 -- only be a single word.
1188 selectWord [] = (0,w)
1189 selectWord ((offset,x):xs)
1190 | offset+length x >= start = (start-offset,take (end-offset) x)
1191 | otherwise = selectWord xs
1194 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1195 | otherwise = Nothing
1198 cmds <- readIORef commands
1199 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1201 completeMacro w = do
1202 cmds <- readIORef commands
1203 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1204 return (filter (w `isPrefixOf`) cmds')
1206 completeIdentifier w = do
1208 rdrs <- GHC.getRdrNamesInScope s
1209 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1211 completeModule w = do
1213 dflags <- GHC.getSessionDynFlags s
1214 let pkg_mods = allExposedModules dflags
1215 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1217 completeHomeModule w = do
1219 g <- GHC.getModuleGraph s
1220 let home_mods = map GHC.ms_mod_name g
1221 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1223 completeSetOptions w = do
1224 return (filter (w `isPrefixOf`) options)
1225 where options = "args":"prog":allFlags
1227 completeFilename = Readline.filenameCompletionFunction
1229 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1231 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1232 unionComplete f1 f2 w = do
1237 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1238 wrapCompleter fun w = do
1241 [] -> return Nothing
1242 [x] -> return (Just (x,[]))
1243 xs -> case getCommonPrefix xs of
1244 "" -> return (Just ("",xs))
1245 pref -> return (Just (pref,xs))
1247 getCommonPrefix :: [String] -> String
1248 getCommonPrefix [] = ""
1249 getCommonPrefix (s:ss) = foldl common s ss
1250 where common s "" = ""
1252 common (c:cs) (d:ds)
1253 | c == d = c : common cs ds
1256 allExposedModules :: DynFlags -> [ModuleName]
1257 allExposedModules dflags
1258 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1260 pkg_db = pkgIdMap (pkgState dflags)
1262 completeCmd = completeNone
1263 completeMacro = completeNone
1264 completeIdentifier = completeNone
1265 completeModule = completeNone
1266 completeHomeModule = completeNone
1267 completeSetOptions = completeNone
1268 completeFilename = completeNone
1269 completeHomeModuleOrFile=completeNone
1270 completeBkpt = completeNone
1273 -- ---------------------------------------------------------------------------
1274 -- User code exception handling
1276 -- This is the exception handler for exceptions generated by the
1277 -- user's code and exceptions coming from children sessions;
1278 -- it normally just prints out the exception. The
1279 -- handler must be recursive, in case showing the exception causes
1280 -- more exceptions to be raised.
1282 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1283 -- raising another exception. We therefore don't put the recursive
1284 -- handler arond the flushing operation, so if stderr is closed
1285 -- GHCi will just die gracefully rather than going into an infinite loop.
1286 handler :: Exception -> GHCi Bool
1288 handler exception = do
1290 io installSignalHandlers
1291 ghciHandle handler (showException exception >> return False)
1293 showException (DynException dyn) =
1294 case fromDynamic dyn of
1295 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1296 Just Interrupted -> io (putStrLn "Interrupted.")
1297 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1298 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1299 Just other_ghc_ex -> io (print other_ghc_ex)
1301 showException other_exception
1302 = io (putStrLn ("*** Exception: " ++ show other_exception))
1304 -----------------------------------------------------------------------------
1305 -- recursive exception handlers
1307 -- Don't forget to unblock async exceptions in the handler, or if we're
1308 -- in an exception loop (eg. let a = error a in a) the ^C exception
1309 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1311 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1312 ghciHandle h (GHCi m) = GHCi $ \s ->
1313 Exception.catch (m s)
1314 (\e -> unGHCi (ghciUnblock (h e)) s)
1316 ghciUnblock :: GHCi a -> GHCi a
1317 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1320 -- ----------------------------------------------------------------------------
1323 expandPath :: String -> GHCi String
1325 case dropWhile isSpace path of
1327 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1328 return (tilde ++ '/':d)
1332 -- ----------------------------------------------------------------------------
1333 -- Windows console setup
1335 setUpConsole :: IO ()
1337 #ifdef mingw32_HOST_OS
1338 -- On Windows we need to set a known code page, otherwise the characters
1339 -- we read from the console will be be in some strange encoding, and
1340 -- similarly for characters we write to the console.
1342 -- At the moment, GHCi pretends all input is Latin-1. In the
1343 -- future we should support UTF-8, but for now we set the code pages
1346 -- It seems you have to set the font in the console window to
1347 -- a Unicode font in order for output to work properly,
1348 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1349 -- (see MSDN for SetConsoleOutputCP()).
1351 setConsoleCP 28591 -- ISO Latin-1
1352 setConsoleOutputCP 28591 -- ISO Latin-1
1356 -- -----------------------------------------------------------------------------
1357 -- commands for debugger
1359 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1361 stepCmd :: String -> GHCi Bool
1362 stepCmd [] = doContinue setStepFlag
1363 stepCmd expression = do
1365 runCommand expression
1367 continueCmd :: String -> GHCi Bool
1368 continueCmd [] = doContinue $ return ()
1369 continueCmd other = do
1370 io $ putStrLn "The continue command accepts no arguments."
1373 doContinue :: IO () -> GHCi Bool
1374 doContinue actionBeforeCont = do
1375 resumeAction <- popResume
1376 case resumeAction of
1378 io $ putStrLn "There is no computation running."
1380 Just (_,_,handle) -> do
1381 io $ actionBeforeCont
1382 session <- getSession
1383 runResult <- io $ GHC.resume session handle
1384 names <- switchOnRunResult runResult
1385 finishEvalExpr names
1388 abandonCmd :: String -> GHCi ()
1393 io $ putStrLn "There is no computation running."
1396 -- the prompt will change to indicate the new context
1398 deleteCmd :: String -> GHCi ()
1399 deleteCmd argLine = do
1400 deleteSwitch $ words argLine
1402 deleteSwitch :: [String] -> GHCi ()
1404 io $ putStrLn "The delete command requires at least one argument."
1405 -- delete all break points
1406 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1407 deleteSwitch idents = do
1408 mapM_ deleteOneBreak idents
1410 deleteOneBreak :: String -> GHCi ()
1412 | all isDigit str = deleteBreak (read str)
1413 | otherwise = return ()
1415 -- handle the "break" command
1416 breakCmd :: String -> GHCi ()
1417 breakCmd argLine = do
1418 session <- getSession
1419 breakSwitch session $ words argLine
1421 breakSwitch :: Session -> [String] -> GHCi ()
1422 breakSwitch _session [] = do
1423 io $ putStrLn "The break command requires at least one argument."
1424 breakSwitch session args@(arg1:rest)
1425 | looksLikeModuleName arg1 = do
1426 mod <- wantInterpretedModule session arg1
1427 breakByModule session mod rest
1428 | all isDigit arg1 = do
1429 (toplevel, _) <- io $ GHC.getContext session
1431 (mod : _) -> breakByModuleLine mod (read arg1) rest
1433 io $ putStrLn "Cannot find default module for breakpoint."
1434 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1435 | otherwise = do -- assume it's a name
1436 names <- io $ GHC.parseName session arg1
1440 let loc = GHC.nameSrcLoc n
1441 modl = GHC.nameModule n
1442 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1443 if not is_interpreted
1444 then noCanDo $ text "module " <> ppr modl <>
1445 text " is not interpreted"
1447 if GHC.isGoodSrcLoc loc
1448 then findBreakAndSet (GHC.nameModule n) $
1449 findBreakByCoord (GHC.srcLocLine loc,
1451 else noCanDo $ text "can't find its location: " <>
1454 noCanDo why = printForUser $
1455 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1458 wantInterpretedModule :: Session -> String -> GHCi Module
1459 wantInterpretedModule session str = do
1460 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1461 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1462 when (not is_interpreted) $
1463 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1466 breakByModule :: Session -> Module -> [String] -> GHCi ()
1467 breakByModule session mod args@(arg1:rest)
1468 | all isDigit arg1 = do -- looks like a line number
1469 breakByModuleLine mod (read arg1) rest
1470 | otherwise = io $ putStrLn "Invalid arguments to :break"
1472 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1473 breakByModuleLine mod line args
1474 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1475 | [col] <- args, all isDigit col =
1476 findBreakAndSet mod $ findBreakByCoord (line, read col)
1477 | otherwise = io $ putStrLn "Invalid arguments to :break"
1479 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1480 findBreakAndSet mod lookupTickTree = do
1481 tickArray <- getTickArray mod
1482 (breakArray, _) <- getModBreak mod
1483 case lookupTickTree tickArray of
1484 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1485 Just (tick, span) -> do
1486 success <- io $ setBreakFlag True breakArray tick
1487 session <- getSession
1491 recordBreak $ BreakLocation
1497 text "Breakpoint " <> ppr nm <>
1499 then text " was already set at " <> ppr span
1500 else text " activated at " <> ppr span
1502 printForUser $ text "Breakpoint could not be activated at"
1505 -- When a line number is specified, the current policy for choosing
1506 -- the best breakpoint is this:
1507 -- - the leftmost complete subexpression on the specified line, or
1508 -- - the leftmost subexpression starting on the specified line, or
1509 -- - the rightmost subexpression enclosing the specified line
1511 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1512 findBreakByLine line arr
1513 | not (inRange (bounds arr) line) = Nothing
1515 listToMaybe (sortBy leftmost_largest complete) `mplus`
1516 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1517 listToMaybe (sortBy rightmost ticks)
1521 starts_here = [ tick | tick@(nm,span) <- ticks,
1522 GHC.srcSpanStartLine span == line ]
1524 (complete,incomplete) = partition ends_here starts_here
1525 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1527 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1528 findBreakByCoord (line, col) arr
1529 | not (inRange (bounds arr) line) = Nothing
1531 listToMaybe (sortBy rightmost contains)
1535 -- the ticks that span this coordinate
1536 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1538 leftmost_smallest (_,a) (_,b) = a `compare` b
1539 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1541 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1542 rightmost (_,a) (_,b) = b `compare` a
1544 spans :: SrcSpan -> (Int,Int) -> Bool
1545 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1546 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1548 start_bold = BS.pack "\ESC[1m"
1549 end_bold = BS.pack "\ESC[0m"
1551 listCmd :: String -> GHCi ()
1555 [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1556 (span,_,_):_ -> io $ listAround span True
1558 -- | list a section of a source file around a particular SrcSpan.
1559 -- If the highlight flag is True, also highlight the span using
1560 -- start_bold/end_bold.
1561 listAround span do_highlight = do
1562 contents <- BS.readFile (unpackFS file)
1564 lines = BS.split '\n' contents
1565 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1566 drop (line1 - 1 - pad_before) $ lines
1567 fst_line = max 1 (line1 - pad_before)
1568 line_nos = [ fst_line .. ]
1570 highlighted | do_highlight = zipWith highlight line_nos these_lines
1571 | otherwise = these_lines
1573 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1574 prefixed = zipWith BS.append bs_line_nos highlighted
1576 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1578 file = GHC.srcSpanFile span
1579 line1 = GHC.srcSpanStartLine span
1580 col1 = GHC.srcSpanStartCol span
1581 line2 = GHC.srcSpanEndLine span
1582 col2 = GHC.srcSpanEndCol span
1584 pad_before | line1 == 1 = 0
1589 | no == line1 && no == line2
1590 = let (a,r) = BS.splitAt col1 line
1591 (b,c) = BS.splitAt (col2-col1) r
1593 BS.concat [a,start_bold,b,end_bold,c]
1595 = let (a,b) = BS.splitAt col1 line in
1596 BS.concat [a, start_bold, b]
1598 = let (a,b) = BS.splitAt col2 line in
1599 BS.concat [a, end_bold, b]
1602 -- --------------------------------------------------------------------------
1605 getTickArray :: Module -> GHCi TickArray
1606 getTickArray modl = do
1608 let arrmap = tickarrays st
1609 case lookupModuleEnv arrmap modl of
1610 Just arr -> return arr
1612 (breakArray, ticks) <- getModBreak modl
1613 let arr = mkTickArray (assocs ticks)
1614 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1617 discardTickArrays :: GHCi ()
1618 discardTickArrays = do
1620 setGHCiState st{tickarrays = emptyModuleEnv}
1622 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1624 = accumArray (flip (:)) [] (1, max_line)
1625 [ (line, (nm,span)) | (nm,span) <- ticks,
1626 line <- srcSpanLines span ]
1628 max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1629 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1630 GHC.srcSpanEndLine span ]
1632 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1633 getModBreak mod = do
1634 session <- getSession
1635 Just mod_info <- io $ GHC.getModuleInfo session mod
1636 let modBreaks = GHC.modInfoModBreaks mod_info
1637 let array = GHC.modBreaks_flags modBreaks
1638 let ticks = GHC.modBreaks_locs modBreaks
1639 return (array, ticks)
1641 lookupModule :: Session -> String -> GHCi Module
1642 lookupModule session modName
1643 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1645 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1646 setBreakFlag toggle array index
1647 | toggle = GHC.setBreakOn array index
1648 | otherwise = GHC.setBreakOff array index
1651 {- these should probably go to the GHC API at some point -}
1652 enableBreakPoint :: Session -> Module -> Int -> IO ()
1653 enableBreakPoint session mod index = return ()
1655 disableBreakPoint :: Session -> Module -> Int -> IO ()
1656 disableBreakPoint session mod index = return ()
1658 activeBreakPoints :: Session -> IO [(Module,Int)]
1659 activeBreakPoints session = return []
1661 enableSingleStep :: Session -> IO ()
1662 enableSingleStep session = return ()
1664 disableSingleStep :: Session -> IO ()
1665 disableSingleStep session = return ()