1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
22 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
23 Type, Module, ModuleName, TyThing(..), Phase,
24 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 forceCmd, 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 printCmd, 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 sprintCmd, 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 sprintCmd = pprintCommand False False
1360 printCmd = pprintCommand True False
1361 forceCmd = pprintCommand False True
1363 pprintCommand bind force str = do
1364 session <- getSession
1365 io $ pprintClosureCommand session bind force str
1367 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1369 stepCmd :: String -> GHCi Bool
1370 stepCmd [] = doContinue setStepFlag
1371 stepCmd expression = do
1373 runCommand expression
1375 continueCmd :: String -> GHCi Bool
1376 continueCmd [] = doContinue $ return ()
1377 continueCmd other = do
1378 io $ putStrLn "The continue command accepts no arguments."
1381 doContinue :: IO () -> GHCi Bool
1382 doContinue actionBeforeCont = do
1383 resumeAction <- popResume
1384 case resumeAction of
1386 io $ putStrLn "There is no computation running."
1388 Just (_,_,handle) -> do
1389 io $ actionBeforeCont
1390 session <- getSession
1391 runResult <- io $ GHC.resume session handle
1392 names <- switchOnRunResult runResult
1393 finishEvalExpr names
1396 abandonCmd :: String -> GHCi ()
1401 io $ putStrLn "There is no computation running."
1404 -- the prompt will change to indicate the new context
1406 deleteCmd :: String -> GHCi ()
1407 deleteCmd argLine = do
1408 deleteSwitch $ words argLine
1410 deleteSwitch :: [String] -> GHCi ()
1412 io $ putStrLn "The delete command requires at least one argument."
1413 -- delete all break points
1414 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1415 deleteSwitch idents = do
1416 mapM_ deleteOneBreak idents
1418 deleteOneBreak :: String -> GHCi ()
1420 | all isDigit str = deleteBreak (read str)
1421 | otherwise = return ()
1423 -- handle the "break" command
1424 breakCmd :: String -> GHCi ()
1425 breakCmd argLine = do
1426 session <- getSession
1427 breakSwitch session $ words argLine
1429 breakSwitch :: Session -> [String] -> GHCi ()
1430 breakSwitch _session [] = do
1431 io $ putStrLn "The break command requires at least one argument."
1432 breakSwitch session args@(arg1:rest)
1433 | looksLikeModuleName arg1 = do
1434 mod <- wantInterpretedModule session arg1
1435 breakByModule session mod rest
1436 | all isDigit arg1 = do
1437 (toplevel, _) <- io $ GHC.getContext session
1439 (mod : _) -> breakByModuleLine mod (read arg1) rest
1441 io $ putStrLn "Cannot find default module for breakpoint."
1442 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1443 | otherwise = do -- assume it's a name
1444 names <- io $ GHC.parseName session arg1
1448 let loc = GHC.nameSrcLoc n
1449 modl = GHC.nameModule n
1450 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1451 if not is_interpreted
1452 then noCanDo $ text "module " <> ppr modl <>
1453 text " is not interpreted"
1455 if GHC.isGoodSrcLoc loc
1456 then findBreakAndSet (GHC.nameModule n) $
1457 findBreakByCoord (GHC.srcLocLine loc,
1459 else noCanDo $ text "can't find its location: " <>
1462 noCanDo why = printForUser $
1463 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1466 wantInterpretedModule :: Session -> String -> GHCi Module
1467 wantInterpretedModule session str = do
1468 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1469 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1470 when (not is_interpreted) $
1471 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1474 breakByModule :: Session -> Module -> [String] -> GHCi ()
1475 breakByModule session mod args@(arg1:rest)
1476 | all isDigit arg1 = do -- looks like a line number
1477 breakByModuleLine mod (read arg1) rest
1478 | otherwise = io $ putStrLn "Invalid arguments to :break"
1480 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1481 breakByModuleLine mod line args
1482 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1483 | [col] <- args, all isDigit col =
1484 findBreakAndSet mod $ findBreakByCoord (line, read col)
1485 | otherwise = io $ putStrLn "Invalid arguments to :break"
1487 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1488 findBreakAndSet mod lookupTickTree = do
1489 tickArray <- getTickArray mod
1490 (breakArray, _) <- getModBreak mod
1491 case lookupTickTree tickArray of
1492 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1493 Just (tick, span) -> do
1494 success <- io $ setBreakFlag True breakArray tick
1495 session <- getSession
1499 recordBreak $ BreakLocation
1505 text "Breakpoint " <> ppr nm <>
1507 then text " was already set at " <> ppr span
1508 else text " activated at " <> ppr span
1510 printForUser $ text "Breakpoint could not be activated at"
1513 -- When a line number is specified, the current policy for choosing
1514 -- the best breakpoint is this:
1515 -- - the leftmost complete subexpression on the specified line, or
1516 -- - the leftmost subexpression starting on the specified line, or
1517 -- - the rightmost subexpression enclosing the specified line
1519 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1520 findBreakByLine line arr
1521 | not (inRange (bounds arr) line) = Nothing
1523 listToMaybe (sortBy leftmost_largest complete) `mplus`
1524 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1525 listToMaybe (sortBy rightmost ticks)
1529 starts_here = [ tick | tick@(nm,span) <- ticks,
1530 GHC.srcSpanStartLine span == line ]
1532 (complete,incomplete) = partition ends_here starts_here
1533 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1535 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1536 findBreakByCoord (line, col) arr
1537 | not (inRange (bounds arr) line) = Nothing
1539 listToMaybe (sortBy rightmost contains)
1543 -- the ticks that span this coordinate
1544 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1546 leftmost_smallest (_,a) (_,b) = a `compare` b
1547 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1549 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1550 rightmost (_,a) (_,b) = b `compare` a
1552 spans :: SrcSpan -> (Int,Int) -> Bool
1553 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1554 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1556 start_bold = BS.pack "\ESC[1m"
1557 end_bold = BS.pack "\ESC[0m"
1559 listCmd :: String -> GHCi ()
1563 [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1564 (span,_,_):_ -> io $ listAround span True
1566 -- | list a section of a source file around a particular SrcSpan.
1567 -- If the highlight flag is True, also highlight the span using
1568 -- start_bold/end_bold.
1569 listAround span do_highlight = do
1570 contents <- BS.readFile (unpackFS file)
1572 lines = BS.split '\n' contents
1573 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1574 drop (line1 - 1 - pad_before) $ lines
1575 fst_line = max 1 (line1 - pad_before)
1576 line_nos = [ fst_line .. ]
1578 highlighted | do_highlight = zipWith highlight line_nos these_lines
1579 | otherwise = these_lines
1581 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1582 prefixed = zipWith BS.append bs_line_nos highlighted
1584 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1586 file = GHC.srcSpanFile span
1587 line1 = GHC.srcSpanStartLine span
1588 col1 = GHC.srcSpanStartCol span
1589 line2 = GHC.srcSpanEndLine span
1590 col2 = GHC.srcSpanEndCol span
1592 pad_before | line1 == 1 = 0
1597 | no == line1 && no == line2
1598 = let (a,r) = BS.splitAt col1 line
1599 (b,c) = BS.splitAt (col2-col1) r
1601 BS.concat [a,start_bold,b,end_bold,c]
1603 = let (a,b) = BS.splitAt col1 line in
1604 BS.concat [a, start_bold, b]
1606 = let (a,b) = BS.splitAt col2 line in
1607 BS.concat [a, end_bold, b]
1610 -- --------------------------------------------------------------------------
1613 getTickArray :: Module -> GHCi TickArray
1614 getTickArray modl = do
1616 let arrmap = tickarrays st
1617 case lookupModuleEnv arrmap modl of
1618 Just arr -> return arr
1620 (breakArray, ticks) <- getModBreak modl
1621 let arr = mkTickArray (assocs ticks)
1622 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1625 discardTickArrays :: GHCi ()
1626 discardTickArrays = do
1628 setGHCiState st{tickarrays = emptyModuleEnv}
1630 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1632 = accumArray (flip (:)) [] (1, max_line)
1633 [ (line, (nm,span)) | (nm,span) <- ticks,
1634 line <- srcSpanLines span ]
1636 max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1637 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1638 GHC.srcSpanEndLine span ]
1640 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1641 getModBreak mod = do
1642 session <- getSession
1643 Just mod_info <- io $ GHC.getModuleInfo session mod
1644 let modBreaks = GHC.modInfoModBreaks mod_info
1645 let array = GHC.modBreaks_flags modBreaks
1646 let ticks = GHC.modBreaks_locs modBreaks
1647 return (array, ticks)
1649 lookupModule :: Session -> String -> GHCi Module
1650 lookupModule session modName
1651 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1653 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1654 setBreakFlag toggle array index
1655 | toggle = GHC.setBreakOn array index
1656 | otherwise = GHC.setBreakOff array index
1659 {- these should probably go to the GHC API at some point -}
1660 enableBreakPoint :: Session -> Module -> Int -> IO ()
1661 enableBreakPoint session mod index = return ()
1663 disableBreakPoint :: Session -> Module -> Int -> IO ()
1664 disableBreakPoint session mod index = return ()
1666 activeBreakPoints :: Session -> IO [(Module,Int)]
1667 activeBreakPoints session = return []
1669 enableSingleStep :: Session -> IO ()
1670 enableSingleStep session = return ()
1672 disableSingleStep :: Session -> IO ()
1673 disableSingleStep session = return ()