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, Resume, SingleStep )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
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 ("back", keepGoing backCmd, False, completeNone),
108 ("browse", keepGoing browseCmd, False, completeModule),
109 ("cd", keepGoing changeDirectory, False, completeFilename),
110 ("check", keepGoing checkModule, False, completeHomeModule),
111 ("continue", continueCmd, False, completeNone),
112 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
113 ("def", keepGoing defineMacro, False, completeIdentifier),
114 ("delete", keepGoing deleteCmd, False, completeNone),
115 ("e", keepGoing editFile, False, completeFilename),
116 ("edit", keepGoing editFile, False, completeFilename),
117 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
118 ("force", keepGoing forceCmd, False, completeIdentifier),
119 ("forward", keepGoing forwardCmd, False, completeNone),
120 ("help", keepGoing help, False, completeNone),
121 ("history", keepGoing historyCmd, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("kind", keepGoing kindOfType, False, completeIdentifier),
124 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
125 ("list", keepGoing listCmd, False, completeNone),
126 ("module", keepGoing setContext, False, completeModule),
127 ("main", keepGoing runMain, False, completeIdentifier),
128 ("print", keepGoing printCmd, False, completeIdentifier),
129 ("quit", quit, False, completeNone),
130 ("reload", keepGoing reloadModule, False, completeNone),
131 ("set", keepGoing setCmd, True, completeSetOptions),
132 ("show", keepGoing showCmd, False, completeNone),
133 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
134 ("step", stepCmd, False, completeIdentifier),
135 ("type", keepGoing typeOfExpr, False, completeIdentifier),
136 ("trace", traceCmd, False, completeIdentifier),
137 ("undef", keepGoing undefineMacro, False, completeMacro),
138 ("unset", keepGoing unsetOptions, True, completeSetOptions)
141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoing a str = a str >> return False
144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoingPaths a str = a (toArgs str) >> return False
147 shortHelpText = "use :? for help.\n"
150 " Commands available from the prompt:\n" ++
152 " <stmt> evaluate/run <stmt>\n" ++
153 " :add <filename> ... add module(s) to the current target set\n" ++
154 " :abandon at a breakpoint, abandon current computation\n" ++
155 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
156 " :break <name> set a breakpoint on the specified function\n" ++
157 " :browse [*]<module> display the names defined by <module>\n" ++
158 " :cd <dir> change directory to <dir>\n" ++
159 " :continue resume after a breakpoint\n" ++
160 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
161 " :def <cmd> <expr> define a command :<cmd>\n" ++
162 " :delete <number> delete the specified breakpoint\n" ++
163 " :delete * delete all breakpoints\n" ++
164 " :edit <file> edit file\n" ++
165 " :edit edit last module\n" ++
166 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
167 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
168 " :help, :? display this list of commands\n" ++
169 " :info [<name> ...] display information about the given names\n" ++
170 " :kind <type> show the kind of <type>\n" ++
171 " :load <filename> ... load module(s) and their dependents\n" ++
172 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
173 " :main [<arguments> ...] run the main function with the given arguments\n" ++
174 " :print [<name> ...] prints a value without forcing its computation\n" ++
175 " :quit exit GHCi\n" ++
176 " :reload reload the current module set\n" ++
178 " :set <option> ... set options\n" ++
179 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
180 " :set prog <progname> set the value returned by System.getProgName\n" ++
181 " :set prompt <prompt> set the prompt used in GHCi\n" ++
182 " :set editor <cmd> set the command used for :edit\n" ++
183 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
185 " :show breaks show active breakpoints\n" ++
186 " :show context show the breakpoint context\n" ++
187 " :show modules show the currently loaded modules\n" ++
188 " :show bindings show the current bindings made at the prompt\n" ++
190 " :sprint [<name> ...] simplifed version of :print\n" ++
191 " :step single-step after stopping at a breakpoint\n"++
192 " :step <expr> single-step into <expr>\n"++
193 " :type <expr> show the type of <expr>\n" ++
194 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
195 " :unset <option> ... unset options\n" ++
196 " :!<command> run the shell command <command>\n" ++
198 " Options for ':set' and ':unset':\n" ++
200 " +r revert top-level expressions after each evaluation\n" ++
201 " +s print timing/memory stats after each evaluation\n" ++
202 " +t print type after evaluation\n" ++
203 " -<flags> most GHC command line flags can also be set here\n" ++
204 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
206 -- Todo: add help for breakpoint commands here
212 win <- System.Win32.getWindowsDirectory
213 return (win `joinFileName` "notepad.exe")
218 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
219 interactiveUI session srcs maybe_expr = do
220 -- HACK! If we happen to get into an infinite loop (eg the user
221 -- types 'let x=x in x' at the prompt), then the thread will block
222 -- on a blackhole, and become unreachable during GC. The GC will
223 -- detect that it is unreachable and send it the NonTermination
224 -- exception. However, since the thread is unreachable, everything
225 -- it refers to might be finalized, including the standard Handles.
226 -- This sounds like a bug, but we don't have a good solution right
232 -- Initialise buffering for the *interpreted* I/O system
233 initInterpBuffering session
235 when (isNothing maybe_expr) $ do
236 -- Only for GHCi (not runghc and ghc -e):
237 -- Turn buffering off for the compiled program's stdout/stderr
239 -- Turn buffering off for GHCi's stdout
241 hSetBuffering stdout NoBuffering
242 -- We don't want the cmd line to buffer any input that might be
243 -- intended for the program, so unbuffer stdin.
244 hSetBuffering stdin NoBuffering
246 -- initial context is just the Prelude
247 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
248 GHC.setContext session [] [prel_mod]
252 Readline.setAttemptedCompletionFunction (Just completeWord)
253 --Readline.parseAndBind "set show-all-if-ambiguous 1"
255 let symbols = "!#$%&*+/<=>?@\\^|-~"
256 specials = "(),;[]`{}"
258 word_break_chars = spaces ++ specials ++ symbols
260 Readline.setBasicWordBreakCharacters word_break_chars
261 Readline.setCompleterWordBreakCharacters word_break_chars
264 default_editor <- findEditor
266 startGHCi (runGHCi srcs maybe_expr)
267 GHCiState{ progname = "<interactive>",
271 editor = default_editor,
277 tickarrays = emptyModuleEnv
281 Readline.resetTerminal Nothing
286 prel_name = GHC.mkModuleName "Prelude"
288 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
289 runGHCi paths maybe_expr = do
290 let read_dot_files = not opt_IgnoreDotGhci
292 when (read_dot_files) $ do
295 exists <- io (doesFileExist file)
297 dir_ok <- io (checkPerms ".")
298 file_ok <- io (checkPerms file)
299 when (dir_ok && file_ok) $ do
300 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
303 Right hdl -> fileLoop hdl False
305 when (read_dot_files) $ do
306 -- Read in $HOME/.ghci
307 either_dir <- io (IO.try (getEnv "HOME"))
311 cwd <- io (getCurrentDirectory)
312 when (dir /= cwd) $ do
313 let file = dir ++ "/.ghci"
314 ok <- io (checkPerms file)
316 either_hdl <- io (IO.try (openFile file ReadMode))
319 Right hdl -> fileLoop hdl False
321 -- Perform a :load for files given on the GHCi command line
322 -- When in -e mode, if the load fails then we want to stop
323 -- immediately rather than going on to evaluate the expression.
324 when (not (null paths)) $ do
325 ok <- ghciHandle (\e -> do showException e; return Failed) $
327 when (isJust maybe_expr && failed ok) $
328 io (exitWith (ExitFailure 1))
330 -- if verbosity is greater than 0, or we are connected to a
331 -- terminal, display the prompt in the interactive loop.
332 is_tty <- io (hIsTerminalDevice stdin)
333 dflags <- getDynFlags
334 let show_prompt = verbosity dflags > 0 || is_tty
339 #if defined(mingw32_HOST_OS)
340 -- The win32 Console API mutates the first character of
341 -- type-ahead when reading from it in a non-buffered manner. Work
342 -- around this by flushing the input buffer of type-ahead characters,
343 -- but only if stdin is available.
344 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
346 Left err | isDoesNotExistError err -> return ()
347 | otherwise -> io (ioError err)
348 Right () -> return ()
350 -- initialise the console if necessary
353 -- enter the interactive loop
354 interactiveLoop is_tty show_prompt
356 -- just evaluate the expression we were given
361 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
364 interactiveLoop is_tty show_prompt =
365 -- Ignore ^C exceptions caught here
366 ghciHandleDyn (\e -> case e of
368 #if defined(mingw32_HOST_OS)
371 interactiveLoop is_tty show_prompt
372 _other -> return ()) $
374 ghciUnblock $ do -- unblock necessary if we recursed from the
375 -- exception handler above.
377 -- read commands from stdin
381 else fileLoop stdin show_prompt
383 fileLoop stdin show_prompt
387 -- NOTE: We only read .ghci files if they are owned by the current user,
388 -- and aren't world writable. Otherwise, we could be accidentally
389 -- running code planted by a malicious third party.
391 -- Furthermore, We only read ./.ghci if . is owned by the current user
392 -- and isn't writable by anyone else. I think this is sufficient: we
393 -- don't need to check .. and ../.. etc. because "." always refers to
394 -- the same directory while a process is running.
396 checkPerms :: String -> IO Bool
398 #ifdef mingw32_HOST_OS
401 Util.handle (\_ -> return False) $ do
402 st <- getFileStatus name
404 if fileOwner st /= me then do
405 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
408 let mode = fileMode st
409 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
410 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
412 putStrLn $ "*** WARNING: " ++ name ++
413 " is writable by someone else, IGNORING!"
418 fileLoop :: Handle -> Bool -> GHCi ()
419 fileLoop hdl show_prompt = do
420 when show_prompt $ do
423 l <- io (IO.try (hGetLine hdl))
425 Left e | isEOFError e -> return ()
426 | InvalidArgument <- etype -> return ()
427 | otherwise -> io (ioError e)
428 where etype = ioeGetErrorType e
429 -- treat InvalidArgument in the same way as EOF:
430 -- this can happen if the user closed stdin, or
431 -- perhaps did getContents which closes stdin at
434 case removeSpaces l of
435 "" -> fileLoop hdl show_prompt
436 l -> do quit <- runCommand l
437 if quit then return () else fileLoop hdl show_prompt
439 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
440 stringLoop [] = return False
441 stringLoop (s:ss) = do
442 case removeSpaces s of
444 l -> do quit <- runCommand l
445 if quit then return True else stringLoop ss
448 session <- getSession
449 (toplevs,exports) <- io (GHC.getContext session)
450 resumes <- io $ GHC.getResumeContext session
456 let ix = GHC.resumeHistoryIx r
458 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
460 let hist = GHC.resumeHistory r !! (ix-1)
461 span <- io $ GHC.getHistorySpan session hist
462 return (brackets (ppr (negate ix) <> char ':'
463 <+> ppr span) <> space)
465 dots | r:rs <- resumes, not (null rs) = text "... "
469 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
470 hsep (map (ppr . GHC.moduleName) exports)
472 deflt_prompt = dots <> context_bit <> modules_bit
474 f ('%':'s':xs) = deflt_prompt <> f xs
475 f ('%':'%':xs) = char '%' <> f xs
476 f (x:xs) = char x <> f xs
480 return (showSDoc (f (prompt st)))
484 readlineLoop :: GHCi ()
486 session <- getSession
487 (mod,imports) <- io (GHC.getContext session)
489 saveSession -- for use by completion
491 mb_span <- getCurrentBreakSpan
493 l <- io (readline prompt `finally` setNonBlockingFD 0)
494 -- readline sometimes puts stdin into blocking mode,
495 -- so we need to put it back for the IO library
500 case removeSpaces l of
505 if quit then return () else readlineLoop
508 runCommand :: String -> GHCi Bool
509 runCommand c = ghciHandle handler (doCommand c)
511 doCommand (':' : command) = specialCommand command
513 = do timeIt $ runStmt stmt GHC.RunToCompletion
516 -- This version is for the GHC command-line option -e. The only difference
517 -- from runCommand is that it catches the ExitException exception and
518 -- exits, rather than printing out the exception.
519 runCommandEval c = ghciHandle handleEval (doCommand c)
521 handleEval (ExitException code) = io (exitWith code)
522 handleEval e = do handler e
523 io (exitWith (ExitFailure 1))
525 doCommand (':' : command) = specialCommand command
527 = do r <- runStmt stmt GHC.RunToCompletion
529 False -> io (exitWith (ExitFailure 1))
530 -- failure to run the command causes exit(1) for ghc -e.
533 runStmt :: String -> SingleStep -> GHCi Bool
535 | null (filter (not.isSpace) stmt) = return False
537 = do st <- getGHCiState
538 session <- getSession
539 result <- io $ withProgName (progname st) $ withArgs (args st) $
540 GHC.runStmt session stmt step
542 return (isRunResultOk result)
545 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
546 afterRunStmt run_result = do
547 mb_result <- switchOnRunResult run_result
548 -- possibly print the type and revert CAFs after evaluating an expression
549 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)
565 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
566 switchOnRunResult GHC.RunFailed = return Nothing
567 switchOnRunResult (GHC.RunException e) = throw e
568 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
569 switchOnRunResult (GHC.RunBreak threadId names info) = do
570 session <- getSession
571 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
572 let modBreaks = GHC.modInfoModBreaks mod_info
573 let ticks = GHC.modBreaks_locs modBreaks
575 -- display information about the breakpoint
576 let location = ticks ! GHC.breakInfo_number info
577 printForUser $ ptext SLIT("Stopped at") <+> ppr location
579 -- run the command set with ":set stop <cmd>"
583 return (Just (True,names))
586 isRunResultOk :: GHC.RunResult -> Bool
587 isRunResultOk (GHC.RunOk _) = True
588 isRunResultOk _ = False
591 showTypeOfName :: Session -> Name -> GHCi ()
592 showTypeOfName session n
593 = do maybe_tything <- io (GHC.lookupName session n)
594 case maybe_tything of
596 Just thing -> showTyThing thing
598 specialCommand :: String -> GHCi Bool
599 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
600 specialCommand str = do
601 let (cmd,rest) = break isSpace str
602 maybe_cmd <- io (lookupCommand cmd)
604 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
605 ++ shortHelpText) >> return False)
606 Just (_,f,_,_) -> f (dropWhile isSpace rest)
608 lookupCommand :: String -> IO (Maybe Command)
609 lookupCommand str = do
610 cmds <- readIORef commands
611 -- look for exact match first, then the first prefix match
612 case [ c | c <- cmds, str == cmdName c ] of
613 c:_ -> return (Just c)
614 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
616 c:_ -> return (Just c)
619 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
620 getCurrentBreakSpan = do
621 session <- getSession
622 resumes <- io $ GHC.getResumeContext session
626 let ix = GHC.resumeHistoryIx r
628 then return (Just (GHC.resumeSpan r))
630 let hist = GHC.resumeHistory r !! (ix-1)
631 span <- io $ GHC.getHistorySpan session hist
634 -----------------------------------------------------------------------------
637 noArgs :: GHCi () -> String -> GHCi ()
639 noArgs m _ = io $ putStrLn "This command takes no arguments"
641 help :: String -> GHCi ()
642 help _ = io (putStr helpText)
644 info :: String -> GHCi ()
645 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
646 info s = do { let names = words s
647 ; session <- getSession
648 ; dflags <- getDynFlags
649 ; let exts = dopt Opt_GlasgowExts dflags
650 ; mapM_ (infoThing exts session) names }
652 infoThing exts session str = io $ do
653 names <- GHC.parseName session str
654 let filtered = filterOutChildren names
655 mb_stuffs <- mapM (GHC.getInfo session) filtered
656 unqual <- GHC.getPrintUnqual session
657 putStrLn (showSDocForUser unqual $
658 vcat (intersperse (text "") $
659 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
661 -- Filter out names whose parent is also there Good
662 -- example is '[]', which is both a type and data
663 -- constructor in the same type
664 filterOutChildren :: [Name] -> [Name]
665 filterOutChildren names = filter (not . parent_is_there) names
666 where parent_is_there n
667 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
671 pprInfo exts (thing, fixity, insts)
672 = pprTyThingInContextLoc exts thing
673 $$ show_fixity fixity
674 $$ vcat (map GHC.pprInstance insts)
677 | fix == GHC.defaultFixity = empty
678 | otherwise = ppr fix <+> ppr (GHC.getName thing)
680 runMain :: String -> GHCi ()
682 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
683 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
686 addModule :: [FilePath] -> GHCi ()
688 io (revertCAFs) -- always revert CAFs on load/add.
689 files <- mapM expandPath files
690 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
691 session <- getSession
692 io (mapM_ (GHC.addTarget session) targets)
693 ok <- io (GHC.load session LoadAllTargets)
696 changeDirectory :: String -> GHCi ()
697 changeDirectory dir = do
698 session <- getSession
699 graph <- io (GHC.getModuleGraph session)
700 when (not (null graph)) $
701 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
702 io (GHC.setTargets session [])
703 io (GHC.load session LoadAllTargets)
704 setContextAfterLoad session []
705 io (GHC.workingDirectoryChanged session)
706 dir <- expandPath dir
707 io (setCurrentDirectory dir)
709 editFile :: String -> GHCi ()
712 -- find the name of the "topmost" file loaded
713 session <- getSession
714 graph0 <- io (GHC.getModuleGraph session)
715 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
716 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
717 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
718 Just file -> do_edit file
719 Nothing -> throwDyn (CmdLineError "unknown file name")
720 | otherwise = do_edit str
726 throwDyn (CmdLineError "editor not set, use :set editor")
727 io $ system (cmd ++ ' ':file)
730 defineMacro :: String -> GHCi ()
732 let (macro_name, definition) = break isSpace s
733 cmds <- io (readIORef commands)
735 then throwDyn (CmdLineError "invalid macro name")
737 if (macro_name `elem` map cmdName cmds)
738 then throwDyn (CmdLineError
739 ("command '" ++ macro_name ++ "' is already defined"))
742 -- give the expression a type signature, so we can be sure we're getting
743 -- something of the right type.
744 let new_expr = '(' : definition ++ ") :: String -> IO String"
746 -- compile the expression
748 maybe_hv <- io (GHC.compileExpr cms new_expr)
751 Just hv -> io (writeIORef commands --
752 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
754 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
756 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
757 stringLoop (lines str)
759 undefineMacro :: String -> GHCi ()
760 undefineMacro macro_name = do
761 cmds <- io (readIORef commands)
762 if (macro_name `elem` map cmdName builtin_commands)
763 then throwDyn (CmdLineError
764 ("command '" ++ macro_name ++ "' cannot be undefined"))
766 if (macro_name `notElem` map cmdName cmds)
767 then throwDyn (CmdLineError
768 ("command '" ++ macro_name ++ "' not defined"))
770 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
773 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
774 loadModule fs = timeIt (loadModule' fs)
776 loadModule_ :: [FilePath] -> GHCi ()
777 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
779 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
780 loadModule' files = do
781 session <- getSession
784 io (GHC.setTargets session [])
785 io (GHC.load session LoadAllTargets)
788 let (filenames, phases) = unzip files
789 exp_filenames <- mapM expandPath filenames
790 let files' = zip exp_filenames phases
791 targets <- io (mapM (uncurry GHC.guessTarget) files')
793 -- NOTE: we used to do the dependency anal first, so that if it
794 -- fails we didn't throw away the current set of modules. This would
795 -- require some re-working of the GHC interface, so we'll leave it
796 -- as a ToDo for now.
798 io (GHC.setTargets session targets)
799 ok <- io (GHC.load session LoadAllTargets)
803 checkModule :: String -> GHCi ()
805 let modl = GHC.mkModuleName m
806 session <- getSession
807 result <- io (GHC.checkModule session modl)
809 Nothing -> io $ putStrLn "Nothing"
810 Just r -> io $ putStrLn (showSDoc (
811 case GHC.checkedModuleInfo r of
812 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
814 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
816 (text "global names: " <+> ppr global) $$
817 (text "local names: " <+> ppr local)
819 afterLoad (successIf (isJust result)) session
821 reloadModule :: String -> GHCi ()
823 io (revertCAFs) -- always revert CAFs on reload.
824 session <- getSession
825 ok <- io (GHC.load session LoadAllTargets)
828 io (revertCAFs) -- always revert CAFs on reload.
829 session <- getSession
830 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
833 afterLoad ok session = do
834 io (revertCAFs) -- always revert CAFs on load.
836 discardActiveBreakPoints
837 graph <- io (GHC.getModuleGraph session)
838 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
839 setContextAfterLoad session graph'
840 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
842 setContextAfterLoad session [] = do
843 prel_mod <- getPrelude
844 io (GHC.setContext session [] [prel_mod])
845 setContextAfterLoad session ms = do
846 -- load a target if one is available, otherwise load the topmost module.
847 targets <- io (GHC.getTargets session)
848 case [ m | Just m <- map (findTarget ms) targets ] of
850 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
851 load_this (last graph')
856 = case filter (`matches` t) ms of
860 summary `matches` Target (TargetModule m) _
861 = GHC.ms_mod_name summary == m
862 summary `matches` Target (TargetFile f _) _
863 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
864 summary `matches` target
867 load_this summary | m <- GHC.ms_mod summary = do
868 b <- io (GHC.moduleIsInterpreted session m)
869 if b then io (GHC.setContext session [m] [])
871 prel_mod <- getPrelude
872 io (GHC.setContext session [] [prel_mod,m])
875 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
876 modulesLoadedMsg ok mods = do
877 dflags <- getDynFlags
878 when (verbosity dflags > 0) $ do
880 | null mods = text "none."
882 punctuate comma (map ppr mods)) <> text "."
885 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
887 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
890 typeOfExpr :: String -> GHCi ()
892 = do cms <- getSession
893 maybe_ty <- io (GHC.exprType cms str)
896 Just ty -> do ty' <- cleanType ty
897 printForUser $ text str <> text " :: " <> ppr ty'
899 kindOfType :: String -> GHCi ()
901 = do cms <- getSession
902 maybe_ty <- io (GHC.typeKind cms str)
905 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
907 quit :: String -> GHCi Bool
910 shellEscape :: String -> GHCi Bool
911 shellEscape str = io (system str >> return False)
913 -----------------------------------------------------------------------------
914 -- Browsing a module's contents
916 browseCmd :: String -> GHCi ()
919 ['*':m] | looksLikeModuleName m -> browseModule m False
920 [m] | looksLikeModuleName m -> browseModule m True
921 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
923 browseModule m exports_only = do
925 modl <- if exports_only then lookupModule m
926 else wantInterpretedModule m
928 -- Temporarily set the context to the module we're interested in,
929 -- just so we can get an appropriate PrintUnqualified
930 (as,bs) <- io (GHC.getContext s)
931 prel_mod <- getPrelude
932 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
933 else GHC.setContext s [modl] [])
934 unqual <- io (GHC.getPrintUnqual s)
935 io (GHC.setContext s as bs)
937 mb_mod_info <- io $ GHC.getModuleInfo s modl
939 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
942 | exports_only = GHC.modInfoExports mod_info
943 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
945 filtered = filterOutChildren names
947 things <- io $ mapM (GHC.lookupName s) filtered
949 dflags <- getDynFlags
950 let exts = dopt Opt_GlasgowExts dflags
951 io (putStrLn (showSDocForUser unqual (
952 vcat (map (pprTyThingInContext exts) (catMaybes things))
954 -- ToDo: modInfoInstances currently throws an exception for
955 -- package modules. When it works, we can do this:
956 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
958 -----------------------------------------------------------------------------
959 -- Setting the module context
962 | all sensible mods = fn mods
963 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
965 (fn, mods) = case str of
966 '+':stuff -> (addToContext, words stuff)
967 '-':stuff -> (removeFromContext, words stuff)
968 stuff -> (newContext, words stuff)
970 sensible ('*':m) = looksLikeModuleName m
971 sensible m = looksLikeModuleName m
973 separate :: Session -> [String] -> [Module] -> [Module]
974 -> GHCi ([Module],[Module])
975 separate session [] as bs = return (as,bs)
976 separate session (('*':str):ms) as bs = do
977 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
978 b <- io $ GHC.moduleIsInterpreted session m
979 if b then separate session ms (m:as) bs
980 else throwDyn (CmdLineError ("module '"
981 ++ GHC.moduleNameString (GHC.moduleName m)
982 ++ "' is not interpreted"))
983 separate session (str:ms) as bs = do
984 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
985 separate session ms as (m:bs)
987 newContext :: [String] -> GHCi ()
990 (as,bs) <- separate s strs [] []
991 prel_mod <- getPrelude
992 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
993 io $ GHC.setContext s as bs'
996 addToContext :: [String] -> GHCi ()
997 addToContext strs = do
999 (as,bs) <- io $ GHC.getContext s
1001 (new_as,new_bs) <- separate s strs [] []
1003 let as_to_add = new_as \\ (as ++ bs)
1004 bs_to_add = new_bs \\ (as ++ bs)
1006 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1009 removeFromContext :: [String] -> GHCi ()
1010 removeFromContext strs = do
1012 (as,bs) <- io $ GHC.getContext s
1014 (as_to_remove,bs_to_remove) <- separate s strs [] []
1016 let as' = as \\ (as_to_remove ++ bs_to_remove)
1017 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1019 io $ GHC.setContext s as' bs'
1021 ----------------------------------------------------------------------------
1024 -- set options in the interpreter. Syntax is exactly the same as the
1025 -- ghc command line, except that certain options aren't available (-C,
1028 -- This is pretty fragile: most options won't work as expected. ToDo:
1029 -- figure out which ones & disallow them.
1031 setCmd :: String -> GHCi ()
1033 = do st <- getGHCiState
1034 let opts = options st
1035 io $ putStrLn (showSDoc (
1036 text "options currently set: " <>
1039 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1042 = case toArgs str of
1043 ("args":args) -> setArgs args
1044 ("prog":prog) -> setProg prog
1045 ("prompt":prompt) -> setPrompt (after 6)
1046 ("editor":cmd) -> setEditor (after 6)
1047 ("stop":cmd) -> setStop (after 4)
1048 wds -> setOptions wds
1049 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1053 setGHCiState st{ args = args }
1057 setGHCiState st{ progname = prog }
1059 io (hPutStrLn stderr "syntax: :set prog <progname>")
1063 setGHCiState st{ editor = cmd }
1067 setGHCiState st{ stop = cmd }
1069 setPrompt value = do
1072 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1073 else setGHCiState st{ prompt = remQuotes value }
1075 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1079 do -- first, deal with the GHCi opts (+s, +t, etc.)
1080 let (plus_opts, minus_opts) = partition isPlus wds
1081 mapM_ setOpt plus_opts
1083 -- then, dynamic flags
1084 dflags <- getDynFlags
1085 let pkg_flags = packageFlags dflags
1086 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1088 if (not (null leftovers))
1089 then throwDyn (CmdLineError ("unrecognised flags: " ++
1093 new_pkgs <- setDynFlags dflags'
1095 -- if the package flags changed, we should reset the context
1096 -- and link the new packages.
1097 dflags <- getDynFlags
1098 when (packageFlags dflags /= pkg_flags) $ do
1099 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1100 session <- getSession
1101 io (GHC.setTargets session [])
1102 io (GHC.load session LoadAllTargets)
1103 io (linkPackages dflags new_pkgs)
1104 setContextAfterLoad session []
1108 unsetOptions :: String -> GHCi ()
1110 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1111 let opts = words str
1112 (minus_opts, rest1) = partition isMinus opts
1113 (plus_opts, rest2) = partition isPlus rest1
1115 if (not (null rest2))
1116 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1119 mapM_ unsetOpt plus_opts
1121 -- can't do GHC flags for now
1122 if (not (null minus_opts))
1123 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1126 isMinus ('-':s) = True
1129 isPlus ('+':s) = True
1133 = case strToGHCiOpt str of
1134 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1135 Just o -> setOption o
1138 = case strToGHCiOpt str of
1139 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1140 Just o -> unsetOption o
1142 strToGHCiOpt :: String -> (Maybe GHCiOption)
1143 strToGHCiOpt "s" = Just ShowTiming
1144 strToGHCiOpt "t" = Just ShowType
1145 strToGHCiOpt "r" = Just RevertCAFs
1146 strToGHCiOpt _ = Nothing
1148 optToStr :: GHCiOption -> String
1149 optToStr ShowTiming = "s"
1150 optToStr ShowType = "t"
1151 optToStr RevertCAFs = "r"
1153 -- ---------------------------------------------------------------------------
1158 ["modules" ] -> showModules
1159 ["bindings"] -> showBindings
1160 ["linker"] -> io showLinkerState
1161 ["breaks"] -> showBkptTable
1162 ["context"] -> showContext
1163 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1166 session <- getSession
1167 let show_one ms = do m <- io (GHC.showModule session ms)
1169 graph <- io (GHC.getModuleGraph session)
1170 mapM_ show_one graph
1174 unqual <- io (GHC.getPrintUnqual s)
1175 bindings <- io (GHC.getBindings s)
1176 mapM_ showTyThing bindings
1179 showTyThing (AnId id) = do
1180 ty' <- cleanType (GHC.idType id)
1181 printForUser $ ppr id <> text " :: " <> ppr ty'
1182 showTyThing _ = return ()
1184 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1185 cleanType :: Type -> GHCi Type
1187 dflags <- getDynFlags
1188 if dopt Opt_GlasgowExts dflags
1190 else return $! GHC.dropForAlls ty
1192 showBkptTable :: GHCi ()
1195 printForUser $ prettyLocations (breaks st)
1197 showContext :: GHCi ()
1199 session <- getSession
1200 resumes <- io $ GHC.getResumeContext session
1201 printForUser $ vcat (map pp_resume (reverse resumes))
1204 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1205 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1208 -- -----------------------------------------------------------------------------
1211 completeNone :: String -> IO [String]
1212 completeNone w = return []
1215 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1216 completeWord w start end = do
1217 line <- Readline.getLineBuffer
1219 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1221 | Just c <- is_cmd line -> do
1222 maybe_cmd <- lookupCommand c
1223 let (n,w') = selectWord (words' 0 line)
1225 Nothing -> return Nothing
1226 Just (_,_,False,complete) -> wrapCompleter complete w
1227 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1228 return (map (drop n) rets)
1229 in wrapCompleter complete' w'
1231 --printf "complete %s, start = %d, end = %d\n" w start end
1232 wrapCompleter completeIdentifier w
1233 where words' _ [] = []
1234 words' n str = let (w,r) = break isSpace str
1235 (s,r') = span isSpace r
1236 in (n,w):words' (n+length w+length s) r'
1237 -- In a Haskell expression we want to parse 'a-b' as three words
1238 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1239 -- only be a single word.
1240 selectWord [] = (0,w)
1241 selectWord ((offset,x):xs)
1242 | offset+length x >= start = (start-offset,take (end-offset) x)
1243 | otherwise = selectWord xs
1246 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1247 | otherwise = Nothing
1250 cmds <- readIORef commands
1251 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1253 completeMacro w = do
1254 cmds <- readIORef commands
1255 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1256 return (filter (w `isPrefixOf`) cmds')
1258 completeIdentifier w = do
1260 rdrs <- GHC.getRdrNamesInScope s
1261 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1263 completeModule w = do
1265 dflags <- GHC.getSessionDynFlags s
1266 let pkg_mods = allExposedModules dflags
1267 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1269 completeHomeModule w = do
1271 g <- GHC.getModuleGraph s
1272 let home_mods = map GHC.ms_mod_name g
1273 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1275 completeSetOptions w = do
1276 return (filter (w `isPrefixOf`) options)
1277 where options = "args":"prog":allFlags
1279 completeFilename = Readline.filenameCompletionFunction
1281 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1283 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1284 unionComplete f1 f2 w = do
1289 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1290 wrapCompleter fun w = do
1293 [] -> return Nothing
1294 [x] -> return (Just (x,[]))
1295 xs -> case getCommonPrefix xs of
1296 "" -> return (Just ("",xs))
1297 pref -> return (Just (pref,xs))
1299 getCommonPrefix :: [String] -> String
1300 getCommonPrefix [] = ""
1301 getCommonPrefix (s:ss) = foldl common s ss
1302 where common s "" = ""
1304 common (c:cs) (d:ds)
1305 | c == d = c : common cs ds
1308 allExposedModules :: DynFlags -> [ModuleName]
1309 allExposedModules dflags
1310 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1312 pkg_db = pkgIdMap (pkgState dflags)
1314 completeCmd = completeNone
1315 completeMacro = completeNone
1316 completeIdentifier = completeNone
1317 completeModule = completeNone
1318 completeHomeModule = completeNone
1319 completeSetOptions = completeNone
1320 completeFilename = completeNone
1321 completeHomeModuleOrFile=completeNone
1322 completeBkpt = completeNone
1325 -- ---------------------------------------------------------------------------
1326 -- User code exception handling
1328 -- This is the exception handler for exceptions generated by the
1329 -- user's code and exceptions coming from children sessions;
1330 -- it normally just prints out the exception. The
1331 -- handler must be recursive, in case showing the exception causes
1332 -- more exceptions to be raised.
1334 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1335 -- raising another exception. We therefore don't put the recursive
1336 -- handler arond the flushing operation, so if stderr is closed
1337 -- GHCi will just die gracefully rather than going into an infinite loop.
1338 handler :: Exception -> GHCi Bool
1340 handler exception = do
1342 io installSignalHandlers
1343 ghciHandle handler (showException exception >> return False)
1345 showException (DynException dyn) =
1346 case fromDynamic dyn of
1347 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1348 Just Interrupted -> io (putStrLn "Interrupted.")
1349 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1350 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1351 Just other_ghc_ex -> io (print other_ghc_ex)
1353 showException other_exception
1354 = io (putStrLn ("*** Exception: " ++ show other_exception))
1356 -----------------------------------------------------------------------------
1357 -- recursive exception handlers
1359 -- Don't forget to unblock async exceptions in the handler, or if we're
1360 -- in an exception loop (eg. let a = error a in a) the ^C exception
1361 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1363 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1364 ghciHandle h (GHCi m) = GHCi $ \s ->
1365 Exception.catch (m s)
1366 (\e -> unGHCi (ghciUnblock (h e)) s)
1368 ghciUnblock :: GHCi a -> GHCi a
1369 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1372 -- ----------------------------------------------------------------------------
1375 expandPath :: String -> GHCi String
1377 case dropWhile isSpace path of
1379 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1380 return (tilde ++ '/':d)
1384 wantInterpretedModule :: String -> GHCi Module
1385 wantInterpretedModule str = do
1386 session <- getSession
1387 modl <- lookupModule str
1388 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1389 when (not is_interpreted) $
1390 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1393 wantNameFromInterpretedModule noCanDo str and_then = do
1394 session <- getSession
1395 names <- io $ GHC.parseName session str
1399 let modl = GHC.nameModule n
1400 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1401 if not is_interpreted
1402 then noCanDo n $ text "module " <> ppr modl <>
1403 text " is not interpreted"
1406 -- ----------------------------------------------------------------------------
1407 -- Windows console setup
1409 setUpConsole :: IO ()
1411 #ifdef mingw32_HOST_OS
1412 -- On Windows we need to set a known code page, otherwise the characters
1413 -- we read from the console will be be in some strange encoding, and
1414 -- similarly for characters we write to the console.
1416 -- At the moment, GHCi pretends all input is Latin-1. In the
1417 -- future we should support UTF-8, but for now we set the code pages
1420 -- It seems you have to set the font in the console window to
1421 -- a Unicode font in order for output to work properly,
1422 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1423 -- (see MSDN for SetConsoleOutputCP()).
1425 setConsoleCP 28591 -- ISO Latin-1
1426 setConsoleOutputCP 28591 -- ISO Latin-1
1430 -- -----------------------------------------------------------------------------
1431 -- commands for debugger
1433 sprintCmd = pprintCommand False False
1434 printCmd = pprintCommand True False
1435 forceCmd = pprintCommand False True
1437 pprintCommand bind force str = do
1438 session <- getSession
1439 io $ pprintClosureCommand session bind force str
1441 stepCmd :: String -> GHCi Bool
1442 stepCmd [] = doContinue GHC.SingleStep
1443 stepCmd expression = runStmt expression GHC.SingleStep
1445 traceCmd :: String -> GHCi Bool
1446 traceCmd [] = doContinue GHC.RunAndLogSteps
1447 traceCmd expression = runStmt expression GHC.RunAndLogSteps
1449 continueCmd :: String -> GHCi Bool
1450 continueCmd [] = doContinue GHC.RunToCompletion
1451 continueCmd other = do
1452 io $ putStrLn "The continue command accepts no arguments."
1455 doContinue :: SingleStep -> GHCi Bool
1456 doContinue step = do
1457 session <- getSession
1458 runResult <- io $ GHC.resume session step
1459 afterRunStmt runResult
1462 abandonCmd :: String -> GHCi ()
1463 abandonCmd = noArgs $ do
1465 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1466 when (not b) $ io $ putStrLn "There is no computation running."
1469 deleteCmd :: String -> GHCi ()
1470 deleteCmd argLine = do
1471 deleteSwitch $ words argLine
1473 deleteSwitch :: [String] -> GHCi ()
1475 io $ putStrLn "The delete command requires at least one argument."
1476 -- delete all break points
1477 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1478 deleteSwitch idents = do
1479 mapM_ deleteOneBreak idents
1481 deleteOneBreak :: String -> GHCi ()
1483 | all isDigit str = deleteBreak (read str)
1484 | otherwise = return ()
1486 historyCmd :: String -> GHCi ()
1487 historyCmd = noArgs $ do
1489 resumes <- io $ GHC.getResumeContext s
1491 [] -> io $ putStrLn "Not stopped at a breakpoint"
1493 let hist = GHC.resumeHistory r
1494 spans <- mapM (io . GHC.getHistorySpan s) hist
1495 printForUser (vcat (map ppr spans))
1497 backCmd :: String -> GHCi ()
1498 backCmd = noArgs $ do
1500 (names, ix, span) <- io $ GHC.back s
1501 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1502 mapM_ (showTypeOfName s) names
1503 -- run the command set with ":set stop <cmd>"
1505 runCommand (stop st)
1508 forwardCmd :: String -> GHCi ()
1509 forwardCmd = noArgs $ do
1511 (names, ix, span) <- io $ GHC.forward s
1512 printForUser $ (if (ix == 0)
1513 then ptext SLIT("Stopped at")
1514 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1515 mapM_ (showTypeOfName s) names
1516 -- run the command set with ":set stop <cmd>"
1518 runCommand (stop st)
1521 -- handle the "break" command
1522 breakCmd :: String -> GHCi ()
1523 breakCmd argLine = do
1524 session <- getSession
1525 breakSwitch session $ words argLine
1527 breakSwitch :: Session -> [String] -> GHCi ()
1528 breakSwitch _session [] = do
1529 io $ putStrLn "The break command requires at least one argument."
1530 breakSwitch session args@(arg1:rest)
1531 | looksLikeModuleName arg1 = do
1532 mod <- wantInterpretedModule arg1
1533 breakByModule session mod rest
1534 | all isDigit arg1 = do
1535 (toplevel, _) <- io $ GHC.getContext session
1537 (mod : _) -> breakByModuleLine mod (read arg1) rest
1539 io $ putStrLn "Cannot find default module for breakpoint."
1540 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1541 | otherwise = do -- try parsing it as an identifier
1542 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1543 let loc = GHC.nameSrcLoc name
1544 if GHC.isGoodSrcLoc loc
1545 then findBreakAndSet (GHC.nameModule name) $
1546 findBreakByCoord (Just (GHC.srcLocFile loc))
1547 (GHC.srcLocLine loc,
1549 else noCanDo name $ text "can't find its location: " <> ppr loc
1551 noCanDo n why = printForUser $
1552 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1554 breakByModule :: Session -> Module -> [String] -> GHCi ()
1555 breakByModule session mod args@(arg1:rest)
1556 | all isDigit arg1 = do -- looks like a line number
1557 breakByModuleLine mod (read arg1) rest
1558 | otherwise = io $ putStrLn "Invalid arguments to :break"
1560 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1561 breakByModuleLine mod line args
1562 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1563 | [col] <- args, all isDigit col =
1564 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1565 | otherwise = io $ putStrLn "Invalid arguments to :break"
1567 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1568 findBreakAndSet mod lookupTickTree = do
1569 tickArray <- getTickArray mod
1570 (breakArray, _) <- getModBreak mod
1571 case lookupTickTree tickArray of
1572 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1573 Just (tick, span) -> do
1574 success <- io $ setBreakFlag True breakArray tick
1575 session <- getSession
1579 recordBreak $ BreakLocation
1585 text "Breakpoint " <> ppr nm <>
1587 then text " was already set at " <> ppr span
1588 else text " activated at " <> ppr span
1590 printForUser $ text "Breakpoint could not be activated at"
1593 -- When a line number is specified, the current policy for choosing
1594 -- the best breakpoint is this:
1595 -- - the leftmost complete subexpression on the specified line, or
1596 -- - the leftmost subexpression starting on the specified line, or
1597 -- - the rightmost subexpression enclosing the specified line
1599 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1600 findBreakByLine line arr
1601 | not (inRange (bounds arr) line) = Nothing
1603 listToMaybe (sortBy leftmost_largest complete) `mplus`
1604 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1605 listToMaybe (sortBy rightmost ticks)
1609 starts_here = [ tick | tick@(nm,span) <- ticks,
1610 GHC.srcSpanStartLine span == line ]
1612 (complete,incomplete) = partition ends_here starts_here
1613 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1615 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1616 -> Maybe (BreakIndex,SrcSpan)
1617 findBreakByCoord mb_file (line, col) arr
1618 | not (inRange (bounds arr) line) = Nothing
1620 listToMaybe (sortBy rightmost contains)
1624 -- the ticks that span this coordinate
1625 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1626 is_correct_file span ]
1628 is_correct_file span
1629 | Just f <- mb_file = GHC.srcSpanFile span == f
1633 leftmost_smallest (_,a) (_,b) = a `compare` b
1634 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1636 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1637 rightmost (_,a) (_,b) = b `compare` a
1639 spans :: SrcSpan -> (Int,Int) -> Bool
1640 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1641 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1643 start_bold = BS.pack "\ESC[1m"
1644 end_bold = BS.pack "\ESC[0m"
1646 listCmd :: String -> GHCi ()
1648 mb_span <- getCurrentBreakSpan
1650 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1651 Just span -> io $ listAround span True
1652 listCmd str = list2 (words str)
1654 list2 [arg] | all isDigit arg = do
1655 session <- getSession
1656 (toplevel, _) <- io $ GHC.getContext session
1658 [] -> io $ putStrLn "No module to list"
1659 (mod : _) -> listModuleLine mod (read arg)
1660 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1661 mod <- wantInterpretedModule arg1
1662 listModuleLine mod (read arg2)
1664 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1665 let loc = GHC.nameSrcLoc name
1666 if GHC.isGoodSrcLoc loc
1668 tickArray <- getTickArray (GHC.nameModule name)
1669 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1670 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1673 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1674 Just (_,span) -> io $ listAround span False
1676 noCanDo name $ text "can't find its location: " <>
1679 noCanDo n why = printForUser $
1680 text "cannot list source code for " <> ppr n <> text ": " <> why
1682 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1684 listModuleLine :: Module -> Int -> GHCi ()
1685 listModuleLine modl line = do
1686 session <- getSession
1687 graph <- io (GHC.getModuleGraph session)
1688 let this = filter ((== modl) . GHC.ms_mod) graph
1690 [] -> panic "listModuleLine"
1692 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1693 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1694 io $ listAround (GHC.srcLocSpan loc) False
1696 -- | list a section of a source file around a particular SrcSpan.
1697 -- If the highlight flag is True, also highlight the span using
1698 -- start_bold/end_bold.
1699 listAround span do_highlight = do
1700 contents <- BS.readFile (unpackFS file)
1702 lines = BS.split '\n' contents
1703 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1704 drop (line1 - 1 - pad_before) $ lines
1705 fst_line = max 1 (line1 - pad_before)
1706 line_nos = [ fst_line .. ]
1708 highlighted | do_highlight = zipWith highlight line_nos these_lines
1709 | otherwise = these_lines
1711 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1712 prefixed = zipWith BS.append bs_line_nos highlighted
1714 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1716 file = GHC.srcSpanFile span
1717 line1 = GHC.srcSpanStartLine span
1718 col1 = GHC.srcSpanStartCol span
1719 line2 = GHC.srcSpanEndLine span
1720 col2 = GHC.srcSpanEndCol span
1722 pad_before | line1 == 1 = 0
1727 | no == line1 && no == line2
1728 = let (a,r) = BS.splitAt col1 line
1729 (b,c) = BS.splitAt (col2-col1) r
1731 BS.concat [a,start_bold,b,end_bold,c]
1733 = let (a,b) = BS.splitAt col1 line in
1734 BS.concat [a, start_bold, b]
1736 = let (a,b) = BS.splitAt col2 line in
1737 BS.concat [a, end_bold, b]
1740 -- --------------------------------------------------------------------------
1743 getTickArray :: Module -> GHCi TickArray
1744 getTickArray modl = do
1746 let arrmap = tickarrays st
1747 case lookupModuleEnv arrmap modl of
1748 Just arr -> return arr
1750 (breakArray, ticks) <- getModBreak modl
1751 let arr = mkTickArray (assocs ticks)
1752 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1755 discardTickArrays :: GHCi ()
1756 discardTickArrays = do
1758 setGHCiState st{tickarrays = emptyModuleEnv}
1760 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1762 = accumArray (flip (:)) [] (1, max_line)
1763 [ (line, (nm,span)) | (nm,span) <- ticks,
1764 line <- srcSpanLines span ]
1766 max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1767 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1768 GHC.srcSpanEndLine span ]
1770 lookupModule :: String -> GHCi Module
1771 lookupModule modName
1772 = do session <- getSession
1773 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1775 -- don't reset the counter back to zero?
1776 discardActiveBreakPoints :: GHCi ()
1777 discardActiveBreakPoints = do
1779 mapM (turnOffBreak.snd) (breaks st)
1780 setGHCiState $ st { breaks = [] }
1782 deleteBreak :: Int -> GHCi ()
1783 deleteBreak identity = do
1785 let oldLocations = breaks st
1786 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1788 then printForUser (text "Breakpoint" <+> ppr identity <+>
1789 text "does not exist")
1791 mapM (turnOffBreak.snd) this
1792 setGHCiState $ st { breaks = rest }
1794 turnOffBreak loc = do
1795 (arr, _) <- getModBreak (breakModule loc)
1796 io $ setBreakFlag False arr (breakTick loc)
1798 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1799 getModBreak mod = do
1800 session <- getSession
1801 Just mod_info <- io $ GHC.getModuleInfo session mod
1802 let modBreaks = GHC.modInfoModBreaks mod_info
1803 let array = GHC.modBreaks_flags modBreaks
1804 let ticks = GHC.modBreaks_locs modBreaks
1805 return (array, ticks)
1807 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1808 setBreakFlag toggle array index
1809 | toggle = GHC.setBreakOn array index
1810 | otherwise = GHC.setBreakOff array index