1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
20 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
21 Type, Module, ModuleName, TyThing(..), Phase,
29 import Outputable hiding (printForUser)
30 import Module -- for ModuleEnv
37 -- Other random utilities
39 import BasicTypes hiding (isTopLevel)
40 import Panic hiding (showException)
46 #ifndef mingw32_HOST_OS
48 #if __GLASGOW_HASKELL__ > 504
52 import GHC.ConsoleHandler ( flushConsole )
53 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
54 import qualified System.Win32
58 import Control.Concurrent ( yield ) -- Used in readline loop
59 import System.Console.Readline as Readline
64 import Control.Exception as Exception
65 -- import Control.Concurrent
70 import System.Environment
71 import System.Exit ( exitWith, ExitCode(..) )
72 import System.Directory
74 import System.IO.Error as IO
78 import Control.Monad as Monad
80 import Foreign.StablePtr ( newStablePtr )
81 import GHC.Exts ( unsafeCoerce# )
82 import GHC.IOBase ( IOErrorType(InvalidArgument) )
84 import Data.IORef ( IORef, readIORef, writeIORef )
86 import System.Posix.Internals ( setNonBlockingFD )
88 -----------------------------------------------------------------------------
92 " / _ \\ /\\ /\\/ __(_)\n"++
93 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
94 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
95 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
97 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
100 GLOBAL_VAR(commands, builtin_commands, [Command])
102 builtin_commands :: [Command]
104 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
105 ("?", keepGoing help, False, completeNone),
106 ("add", keepGoingPaths addModule, False, completeFilename),
107 ("break", breakCmd, False, completeIdentifier),
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", deleteCmd, False, completeNone),
115 ("e", keepGoing editFile, False, completeFilename),
116 ("edit", keepGoing editFile, False, completeFilename),
117 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
118 ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
119 ("help", keepGoing help, False, completeNone),
120 ("info", keepGoing info, False, completeIdentifier),
121 ("kind", keepGoing kindOfType, False, completeIdentifier),
122 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
123 ("module", keepGoing setContext, False, completeModule),
124 ("main", keepGoing runMain, False, completeIdentifier),
125 ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
126 ("quit", quit, False, completeNone),
127 ("reload", keepGoing reloadModule, False, completeNone),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
131 ("step", stepCmd, False, completeIdentifier),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("undef", keepGoing undefineMacro, False, completeMacro),
134 ("unset", keepGoing unsetOptions, True, completeSetOptions)
137 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
138 keepGoing a str = a str >> return False
140 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoingPaths a str = a (toArgs str) >> return False
143 shortHelpText = "use :? for help.\n"
146 " Commands available from the prompt:\n" ++
148 " <stmt> evaluate/run <stmt>\n" ++
149 " :add <filename> ... add module(s) to the current target set\n" ++
150 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
151 " :break <name> set a breakpoint on the specified function\n" ++
152 " :browse [*]<module> display the names defined by <module>\n" ++
153 " :cd <dir> change directory to <dir>\n" ++
154 " :continue resume after a breakpoint\n" ++
155 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
156 " :def <cmd> <expr> define a command :<cmd>\n" ++
157 " :delete <number> delete the specified breakpoint\n" ++
158 " :delete * delete all breakpoints\n" ++
159 " :edit <file> edit file\n" ++
160 " :edit edit last module\n" ++
161 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
162 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
163 " :help, :? display this list of commands\n" ++
164 " :info [<name> ...] display information about the given names\n" ++
165 " :kind <type> show the kind of <type>\n" ++
166 " :load <filename> ... load module(s) and their dependents\n" ++
167 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
168 " :main [<arguments> ...] run the main function with the given arguments\n" ++
169 " :print [<name> ...] prints a value without forcing its computation\n" ++
170 " :quit exit GHCi\n" ++
171 " :reload reload the current module set\n" ++
173 " :set <option> ... set options\n" ++
174 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
175 " :set prog <progname> set the value returned by System.getProgName\n" ++
176 " :set prompt <prompt> set the prompt used in GHCi\n" ++
177 " :set editor <cmd> set the command used for :edit\n" ++
179 " :show breaks show active breakpoints\n" ++
180 " :show context show the breakpoint context\n" ++
181 " :show modules show the currently loaded modules\n" ++
182 " :show bindings show the current bindings made at the prompt\n" ++
184 " :sprint [<name> ...] simplifed version of :print\n" ++
185 " :step single-step after stopping at a breakpoint\n"++
186 " :step <expr> single-step into <expr>\n"++
187 " :type <expr> show the type of <expr>\n" ++
188 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
189 " :unset <option> ... unset options\n" ++
190 " :!<command> run the shell command <command>\n" ++
192 " Options for ':set' and ':unset':\n" ++
194 " +r revert top-level expressions after each evaluation\n" ++
195 " +s print timing/memory stats after each evaluation\n" ++
196 " +t print type after evaluation\n" ++
197 " -<flags> most GHC command line flags can also be set here\n" ++
198 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
200 -- Todo: add help for breakpoint commands here
206 win <- System.Win32.getWindowsDirectory
207 return (win `joinFileName` "notepad.exe")
212 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
213 interactiveUI session srcs maybe_expr = do
214 -- HACK! If we happen to get into an infinite loop (eg the user
215 -- types 'let x=x in x' at the prompt), then the thread will block
216 -- on a blackhole, and become unreachable during GC. The GC will
217 -- detect that it is unreachable and send it the NonTermination
218 -- exception. However, since the thread is unreachable, everything
219 -- it refers to might be finalized, including the standard Handles.
220 -- This sounds like a bug, but we don't have a good solution right
226 -- Initialise buffering for the *interpreted* I/O system
227 initInterpBuffering session
229 when (isNothing maybe_expr) $ do
230 -- Only for GHCi (not runghc and ghc -e):
231 -- Turn buffering off for the compiled program's stdout/stderr
233 -- Turn buffering off for GHCi's stdout
235 hSetBuffering stdout NoBuffering
236 -- We don't want the cmd line to buffer any input that might be
237 -- intended for the program, so unbuffer stdin.
238 hSetBuffering stdin NoBuffering
240 -- initial context is just the Prelude
241 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
242 GHC.setContext session [] [prel_mod]
246 Readline.setAttemptedCompletionFunction (Just completeWord)
247 --Readline.parseAndBind "set show-all-if-ambiguous 1"
249 let symbols = "!#$%&*+/<=>?@\\^|-~"
250 specials = "(),;[]`{}"
252 word_break_chars = spaces ++ specials ++ symbols
254 Readline.setBasicWordBreakCharacters word_break_chars
255 Readline.setCompleterWordBreakCharacters word_break_chars
258 default_editor <- findEditor
260 startGHCi (runGHCi srcs maybe_expr)
261 GHCiState{ progname = "<interactive>",
264 editor = default_editor,
269 breaks = emptyActiveBreakPoints,
270 tickarrays = emptyModuleEnv
274 Readline.resetTerminal Nothing
279 prel_name = GHC.mkModuleName "Prelude"
281 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
282 runGHCi paths maybe_expr = do
283 let read_dot_files = not opt_IgnoreDotGhci
285 when (read_dot_files) $ do
288 exists <- io (doesFileExist file)
290 dir_ok <- io (checkPerms ".")
291 file_ok <- io (checkPerms file)
292 when (dir_ok && file_ok) $ do
293 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
296 Right hdl -> fileLoop hdl False
298 when (read_dot_files) $ do
299 -- Read in $HOME/.ghci
300 either_dir <- io (IO.try (getEnv "HOME"))
304 cwd <- io (getCurrentDirectory)
305 when (dir /= cwd) $ do
306 let file = dir ++ "/.ghci"
307 ok <- io (checkPerms file)
309 either_hdl <- io (IO.try (openFile file ReadMode))
312 Right hdl -> fileLoop hdl False
314 -- Perform a :load for files given on the GHCi command line
315 -- When in -e mode, if the load fails then we want to stop
316 -- immediately rather than going on to evaluate the expression.
317 when (not (null paths)) $ do
318 ok <- ghciHandle (\e -> do showException e; return Failed) $
320 when (isJust maybe_expr && failed ok) $
321 io (exitWith (ExitFailure 1))
323 -- if verbosity is greater than 0, or we are connected to a
324 -- terminal, display the prompt in the interactive loop.
325 is_tty <- io (hIsTerminalDevice stdin)
326 dflags <- getDynFlags
327 let show_prompt = verbosity dflags > 0 || is_tty
332 #if defined(mingw32_HOST_OS)
333 -- The win32 Console API mutates the first character of
334 -- type-ahead when reading from it in a non-buffered manner. Work
335 -- around this by flushing the input buffer of type-ahead characters,
336 -- but only if stdin is available.
337 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
339 Left err | isDoesNotExistError err -> return ()
340 | otherwise -> io (ioError err)
341 Right () -> return ()
343 -- initialise the console if necessary
346 -- enter the interactive loop
347 interactiveLoop is_tty show_prompt
349 -- just evaluate the expression we were given
354 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
357 interactiveLoop is_tty show_prompt =
358 -- Ignore ^C exceptions caught here
359 ghciHandleDyn (\e -> case e of
361 #if defined(mingw32_HOST_OS)
364 interactiveLoop is_tty show_prompt
365 _other -> return ()) $
367 ghciUnblock $ do -- unblock necessary if we recursed from the
368 -- exception handler above.
370 -- read commands from stdin
374 else fileLoop stdin show_prompt
376 fileLoop stdin show_prompt
380 -- NOTE: We only read .ghci files if they are owned by the current user,
381 -- and aren't world writable. Otherwise, we could be accidentally
382 -- running code planted by a malicious third party.
384 -- Furthermore, We only read ./.ghci if . is owned by the current user
385 -- and isn't writable by anyone else. I think this is sufficient: we
386 -- don't need to check .. and ../.. etc. because "." always refers to
387 -- the same directory while a process is running.
389 checkPerms :: String -> IO Bool
391 #ifdef mingw32_HOST_OS
394 Util.handle (\_ -> return False) $ do
395 st <- getFileStatus name
397 if fileOwner st /= me then do
398 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
401 let mode = fileMode st
402 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
403 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
405 putStrLn $ "*** WARNING: " ++ name ++
406 " is writable by someone else, IGNORING!"
411 fileLoop :: Handle -> Bool -> GHCi ()
412 fileLoop hdl show_prompt = do
413 session <- getSession
414 (mod,imports) <- io (GHC.getContext session)
416 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
417 l <- io (IO.try (hGetLine hdl))
419 Left e | isEOFError e -> return ()
420 | InvalidArgument <- etype -> return ()
421 | otherwise -> io (ioError e)
422 where etype = ioeGetErrorType e
423 -- treat InvalidArgument in the same way as EOF:
424 -- this can happen if the user closed stdin, or
425 -- perhaps did getContents which closes stdin at
428 case removeSpaces l of
429 "" -> fileLoop hdl show_prompt
430 l -> do quit <- runCommand l
431 if quit then return () else fileLoop hdl show_prompt
433 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
434 stringLoop [] = return False
435 stringLoop (s:ss) = do
436 case removeSpaces s of
438 l -> do quit <- runCommand l
439 if quit then return True else stringLoop ss
441 mkPrompt toplevs exports prompt
442 = showSDoc $ f prompt
444 f ('%':'s':xs) = perc_s <> f xs
445 f ('%':'%':xs) = char '%' <> f xs
446 f (x:xs) = char x <> f xs
449 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
450 hsep (map (ppr . GHC.moduleName) exports)
454 readlineLoop :: GHCi ()
456 session <- getSession
457 (mod,imports) <- io (GHC.getContext session)
459 saveSession -- for use by completion
461 l <- io (readline (mkPrompt mod imports (prompt st))
462 `finally` setNonBlockingFD 0)
463 -- readline sometimes puts stdin into blocking mode,
464 -- so we need to put it back for the IO library
469 case removeSpaces l of
474 if quit then return () else readlineLoop
477 runCommand :: String -> GHCi Bool
478 runCommand c = ghciHandle handler (doCommand c)
480 doCommand (':' : command) = specialCommand command
482 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
485 -- This version is for the GHC command-line option -e. The only difference
486 -- from runCommand is that it catches the ExitException exception and
487 -- exits, rather than printing out the exception.
488 runCommandEval c = ghciHandle handleEval (doCommand c)
490 handleEval (ExitException code) = io (exitWith code)
491 handleEval e = do handler e
492 io (exitWith (ExitFailure 1))
494 doCommand (':' : command) = specialCommand command
496 = do nms <- runStmt stmt
498 Nothing -> io (exitWith (ExitFailure 1))
499 -- failure to run the command causes exit(1) for ghc -e.
500 _ -> finishEvalExpr nms
502 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
504 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
506 = do st <- getGHCiState
507 session <- getSession
508 result <- io $ withProgName (progname st) $ withArgs (args st) $
509 GHC.runStmt session stmt
510 switchOnRunResult result
512 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
513 switchOnRunResult GHC.RunFailed = return Nothing
514 switchOnRunResult (GHC.RunException e) = throw e
515 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
516 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
517 session <- getSession
518 Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
519 let modBreaks = GHC.modInfoModBreaks mod_info
520 let ticks = GHC.modBreaks_locs modBreaks
522 -- display information about the breakpoint
523 let location = ticks ! breakInfo_number info
524 printForUser $ ptext SLIT("Stopped at") <+> ppr location
526 pushResume location threadId resume
527 return (Just (True,names))
529 -- possibly print the type and revert CAFs after evaluating an expression
530 finishEvalExpr mb_names
531 = do show_types <- isOptionSet ShowType
532 session <- getSession
535 Just (is_break,names) ->
536 when (is_break || show_types) $
537 mapM_ (showTypeOfName session) names
540 io installSignalHandlers
541 b <- isOptionSet RevertCAFs
542 io (when b revertCAFs)
545 showTypeOfName :: Session -> Name -> GHCi ()
546 showTypeOfName session n
547 = do maybe_tything <- io (GHC.lookupName session n)
548 case maybe_tything of
550 Just thing -> showTyThing thing
552 specialCommand :: String -> GHCi Bool
553 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
554 specialCommand str = do
555 let (cmd,rest) = break isSpace str
556 maybe_cmd <- io (lookupCommand cmd)
558 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
559 ++ shortHelpText) >> return False)
560 Just (_,f,_,_) -> f (dropWhile isSpace rest)
562 lookupCommand :: String -> IO (Maybe Command)
563 lookupCommand str = do
564 cmds <- readIORef commands
565 -- look for exact match first, then the first prefix match
566 case [ c | c <- cmds, str == cmdName c ] of
567 c:_ -> return (Just c)
568 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
570 c:_ -> return (Just c)
572 -----------------------------------------------------------------------------
575 help :: String -> GHCi ()
576 help _ = io (putStr helpText)
578 info :: String -> GHCi ()
579 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
580 info s = do { let names = words s
581 ; session <- getSession
582 ; dflags <- getDynFlags
583 ; let exts = dopt Opt_GlasgowExts dflags
584 ; mapM_ (infoThing exts session) names }
586 infoThing exts session str = io $ do
587 names <- GHC.parseName session str
588 let filtered = filterOutChildren names
589 mb_stuffs <- mapM (GHC.getInfo session) filtered
590 unqual <- GHC.getPrintUnqual session
591 putStrLn (showSDocForUser unqual $
592 vcat (intersperse (text "") $
593 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
595 -- Filter out names whose parent is also there Good
596 -- example is '[]', which is both a type and data
597 -- constructor in the same type
598 filterOutChildren :: [Name] -> [Name]
599 filterOutChildren names = filter (not . parent_is_there) names
600 where parent_is_there n
601 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
605 pprInfo exts (thing, fixity, insts)
606 = pprTyThingInContextLoc exts thing
607 $$ show_fixity fixity
608 $$ vcat (map GHC.pprInstance insts)
611 | fix == GHC.defaultFixity = empty
612 | otherwise = ppr fix <+> ppr (GHC.getName thing)
614 -----------------------------------------------------------------------------
617 runMain :: String -> GHCi ()
619 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
620 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
623 addModule :: [FilePath] -> GHCi ()
625 io (revertCAFs) -- always revert CAFs on load/add.
626 files <- mapM expandPath files
627 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
628 session <- getSession
629 io (mapM_ (GHC.addTarget session) targets)
630 ok <- io (GHC.load session LoadAllTargets)
633 changeDirectory :: String -> GHCi ()
634 changeDirectory dir = do
635 session <- getSession
636 graph <- io (GHC.getModuleGraph session)
637 when (not (null graph)) $
638 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
639 io (GHC.setTargets session [])
640 io (GHC.load session LoadAllTargets)
641 setContextAfterLoad session []
642 io (GHC.workingDirectoryChanged session)
643 dir <- expandPath dir
644 io (setCurrentDirectory dir)
646 editFile :: String -> GHCi ()
649 -- find the name of the "topmost" file loaded
650 session <- getSession
651 graph0 <- io (GHC.getModuleGraph session)
652 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
653 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
654 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
655 Just file -> do_edit file
656 Nothing -> throwDyn (CmdLineError "unknown file name")
657 | otherwise = do_edit str
663 throwDyn (CmdLineError "editor not set, use :set editor")
664 io $ system (cmd ++ ' ':file)
667 defineMacro :: String -> GHCi ()
669 let (macro_name, definition) = break isSpace s
670 cmds <- io (readIORef commands)
672 then throwDyn (CmdLineError "invalid macro name")
674 if (macro_name `elem` map cmdName cmds)
675 then throwDyn (CmdLineError
676 ("command '" ++ macro_name ++ "' is already defined"))
679 -- give the expression a type signature, so we can be sure we're getting
680 -- something of the right type.
681 let new_expr = '(' : definition ++ ") :: String -> IO String"
683 -- compile the expression
685 maybe_hv <- io (GHC.compileExpr cms new_expr)
688 Just hv -> io (writeIORef commands --
689 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
691 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
693 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
694 stringLoop (lines str)
696 undefineMacro :: String -> GHCi ()
697 undefineMacro macro_name = do
698 cmds <- io (readIORef commands)
699 if (macro_name `elem` map cmdName builtin_commands)
700 then throwDyn (CmdLineError
701 ("command '" ++ macro_name ++ "' cannot be undefined"))
703 if (macro_name `notElem` map cmdName cmds)
704 then throwDyn (CmdLineError
705 ("command '" ++ macro_name ++ "' not defined"))
707 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
710 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
711 loadModule fs = timeIt (loadModule' fs)
713 loadModule_ :: [FilePath] -> GHCi ()
714 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
716 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
717 loadModule' files = do
718 session <- getSession
721 io (GHC.setTargets session [])
722 io (GHC.load session LoadAllTargets)
725 let (filenames, phases) = unzip files
726 exp_filenames <- mapM expandPath filenames
727 let files' = zip exp_filenames phases
728 targets <- io (mapM (uncurry GHC.guessTarget) files')
730 -- NOTE: we used to do the dependency anal first, so that if it
731 -- fails we didn't throw away the current set of modules. This would
732 -- require some re-working of the GHC interface, so we'll leave it
733 -- as a ToDo for now.
735 io (GHC.setTargets session targets)
736 ok <- io (GHC.load session LoadAllTargets)
740 checkModule :: String -> GHCi ()
742 let modl = GHC.mkModuleName m
743 session <- getSession
744 result <- io (GHC.checkModule session modl)
746 Nothing -> io $ putStrLn "Nothing"
747 Just r -> io $ putStrLn (showSDoc (
748 case GHC.checkedModuleInfo r of
749 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
751 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
753 (text "global names: " <+> ppr global) $$
754 (text "local names: " <+> ppr local)
756 afterLoad (successIf (isJust result)) session
758 reloadModule :: String -> GHCi ()
760 io (revertCAFs) -- always revert CAFs on reload.
761 session <- getSession
762 ok <- io (GHC.load session LoadAllTargets)
765 io (revertCAFs) -- always revert CAFs on reload.
766 session <- getSession
767 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
770 afterLoad ok session = do
771 io (revertCAFs) -- always revert CAFs on load.
774 discardActiveBreakPoints
775 graph <- io (GHC.getModuleGraph session)
776 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
777 setContextAfterLoad session graph'
778 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
780 setContextAfterLoad session [] = do
781 prel_mod <- getPrelude
782 io (GHC.setContext session [] [prel_mod])
783 setContextAfterLoad session ms = do
784 -- load a target if one is available, otherwise load the topmost module.
785 targets <- io (GHC.getTargets session)
786 case [ m | Just m <- map (findTarget ms) targets ] of
788 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
789 load_this (last graph')
794 = case filter (`matches` t) ms of
798 summary `matches` Target (TargetModule m) _
799 = GHC.ms_mod_name summary == m
800 summary `matches` Target (TargetFile f _) _
801 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
802 summary `matches` target
805 load_this summary | m <- GHC.ms_mod summary = do
806 b <- io (GHC.moduleIsInterpreted session m)
807 if b then io (GHC.setContext session [m] [])
809 prel_mod <- getPrelude
810 io (GHC.setContext session [] [prel_mod,m])
813 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
814 modulesLoadedMsg ok mods = do
815 dflags <- getDynFlags
816 when (verbosity dflags > 0) $ do
818 | null mods = text "none."
820 punctuate comma (map ppr mods)) <> text "."
823 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
825 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
828 typeOfExpr :: String -> GHCi ()
830 = do cms <- getSession
831 maybe_ty <- io (GHC.exprType cms str)
834 Just ty -> do ty' <- cleanType ty
835 printForUser $ text str <> text " :: " <> ppr ty'
837 kindOfType :: String -> GHCi ()
839 = do cms <- getSession
840 maybe_ty <- io (GHC.typeKind cms str)
843 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
845 quit :: String -> GHCi Bool
848 shellEscape :: String -> GHCi Bool
849 shellEscape str = io (system str >> return False)
851 -----------------------------------------------------------------------------
852 -- create tags file for currently loaded modules.
854 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
856 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
857 createCTagsFileCmd file = ghciCreateTagsFile CTags file
859 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
860 createETagsFileCmd file = ghciCreateTagsFile ETags file
862 data TagsKind = ETags | CTags
864 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
865 ghciCreateTagsFile kind file = do
866 session <- getSession
867 io $ createTagsFile session kind file
870 -- - remove restriction that all modules must be interpreted
871 -- (problem: we don't know source locations for entities unless
872 -- we compiled the module.
874 -- - extract createTagsFile so it can be used from the command-line
875 -- (probably need to fix first problem before this is useful).
877 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
878 createTagsFile session tagskind tagFile = do
879 graph <- GHC.getModuleGraph session
880 let ms = map GHC.ms_mod graph
882 is_interpreted <- GHC.moduleIsInterpreted session m
883 -- should we just skip these?
884 when (not is_interpreted) $
885 throwDyn (CmdLineError ("module '"
886 ++ GHC.moduleNameString (GHC.moduleName m)
887 ++ "' is not interpreted"))
888 mbModInfo <- GHC.getModuleInfo session m
890 | Just modinfo <- mbModInfo,
891 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
892 | otherwise = GHC.alwaysQualify
895 Just modInfo -> return $! listTags unqual modInfo
898 mtags <- mapM tagModule ms
899 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
901 Left e -> hPutStrLn stderr $ ioeGetErrorString e
904 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
905 listTags unqual modInfo =
906 [ tagInfo unqual name loc
907 | name <- GHC.modInfoExports modInfo
908 , let loc = nameSrcLoc name
912 type TagInfo = (String -- tag name
915 ,Int -- column number
918 -- get tag info, for later translation into Vim or Emacs style
919 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
920 tagInfo unqual name loc
921 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
922 , showSDocForUser unqual $ ftext (srcLocFile loc)
927 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
928 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
929 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
930 IO.try (writeFile file tags)
931 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
932 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
933 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
934 tagGroups <- mapM tagFileGroup groups
935 IO.try (writeFile file $ concat tagGroups)
937 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
938 tagFileGroup group@((_,fileName,_,_):_) = do
939 file <- readFile fileName -- need to get additional info from sources..
940 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
941 sortedGroup = sortLe byLine group
942 tags = unlines $ perFile sortedGroup 1 0 $ lines file
943 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
944 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
945 perFile (tagInfo:tags) (count+1) (pos+length line) lines
946 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
947 showETag tagInfo line pos : perFile tags count pos lines
948 perFile tags count pos lines = []
950 -- simple ctags format, for Vim et al
951 showTag :: TagInfo -> String
952 showTag (tag,file,lineNo,colNo)
953 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
955 -- etags format, for Emacs/XEmacs
956 showETag :: TagInfo -> String -> Int -> String
957 showETag (tag,file,lineNo,colNo) line charPos
958 = take colNo line ++ tag
960 ++ "\x01" ++ show lineNo
961 ++ "," ++ show charPos
963 -----------------------------------------------------------------------------
964 -- Browsing a module's contents
966 browseCmd :: String -> GHCi ()
969 ['*':m] | looksLikeModuleName m -> browseModule m False
970 [m] | looksLikeModuleName m -> browseModule m True
971 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
973 browseModule m exports_only = do
975 modl <- if exports_only then lookupModule s m
976 else wantInterpretedModule s m
978 -- Temporarily set the context to the module we're interested in,
979 -- just so we can get an appropriate PrintUnqualified
980 (as,bs) <- io (GHC.getContext s)
981 prel_mod <- getPrelude
982 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
983 else GHC.setContext s [modl] [])
984 unqual <- io (GHC.getPrintUnqual s)
985 io (GHC.setContext s as bs)
987 mb_mod_info <- io $ GHC.getModuleInfo s modl
989 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
992 | exports_only = GHC.modInfoExports mod_info
993 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
995 filtered = filterOutChildren names
997 things <- io $ mapM (GHC.lookupName s) filtered
999 dflags <- getDynFlags
1000 let exts = dopt Opt_GlasgowExts dflags
1001 io (putStrLn (showSDocForUser unqual (
1002 vcat (map (pprTyThingInContext exts) (catMaybes things))
1004 -- ToDo: modInfoInstances currently throws an exception for
1005 -- package modules. When it works, we can do this:
1006 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1008 -----------------------------------------------------------------------------
1009 -- Setting the module context
1012 | all sensible mods = fn mods
1013 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1015 (fn, mods) = case str of
1016 '+':stuff -> (addToContext, words stuff)
1017 '-':stuff -> (removeFromContext, words stuff)
1018 stuff -> (newContext, words stuff)
1020 sensible ('*':m) = looksLikeModuleName m
1021 sensible m = looksLikeModuleName m
1023 separate :: Session -> [String] -> [Module] -> [Module]
1024 -> GHCi ([Module],[Module])
1025 separate session [] as bs = return (as,bs)
1026 separate session (('*':str):ms) as bs = do
1027 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1028 b <- io $ GHC.moduleIsInterpreted session m
1029 if b then separate session ms (m:as) bs
1030 else throwDyn (CmdLineError ("module '"
1031 ++ GHC.moduleNameString (GHC.moduleName m)
1032 ++ "' is not interpreted"))
1033 separate session (str:ms) as bs = do
1034 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1035 separate session ms as (m:bs)
1037 newContext :: [String] -> GHCi ()
1038 newContext strs = do
1040 (as,bs) <- separate s strs [] []
1041 prel_mod <- getPrelude
1042 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1043 io $ GHC.setContext s as bs'
1046 addToContext :: [String] -> GHCi ()
1047 addToContext strs = do
1049 (as,bs) <- io $ GHC.getContext s
1051 (new_as,new_bs) <- separate s strs [] []
1053 let as_to_add = new_as \\ (as ++ bs)
1054 bs_to_add = new_bs \\ (as ++ bs)
1056 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1059 removeFromContext :: [String] -> GHCi ()
1060 removeFromContext strs = do
1062 (as,bs) <- io $ GHC.getContext s
1064 (as_to_remove,bs_to_remove) <- separate s strs [] []
1066 let as' = as \\ (as_to_remove ++ bs_to_remove)
1067 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1069 io $ GHC.setContext s as' bs'
1071 ----------------------------------------------------------------------------
1074 -- set options in the interpreter. Syntax is exactly the same as the
1075 -- ghc command line, except that certain options aren't available (-C,
1078 -- This is pretty fragile: most options won't work as expected. ToDo:
1079 -- figure out which ones & disallow them.
1081 setCmd :: String -> GHCi ()
1083 = do st <- getGHCiState
1084 let opts = options st
1085 io $ putStrLn (showSDoc (
1086 text "options currently set: " <>
1089 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1092 = case toArgs str of
1093 ("args":args) -> setArgs args
1094 ("prog":prog) -> setProg prog
1095 ("prompt":prompt) -> setPrompt (after 6)
1096 ("editor":cmd) -> setEditor (after 6)
1097 wds -> setOptions wds
1098 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1102 setGHCiState st{ args = args }
1106 setGHCiState st{ progname = prog }
1108 io (hPutStrLn stderr "syntax: :set prog <progname>")
1112 setGHCiState st{ editor = cmd }
1114 setPrompt value = do
1117 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1118 else setGHCiState st{ prompt = remQuotes value }
1120 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1124 do -- first, deal with the GHCi opts (+s, +t, etc.)
1125 let (plus_opts, minus_opts) = partition isPlus wds
1126 mapM_ setOpt plus_opts
1128 -- then, dynamic flags
1129 dflags <- getDynFlags
1130 let pkg_flags = packageFlags dflags
1131 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1133 if (not (null leftovers))
1134 then throwDyn (CmdLineError ("unrecognised flags: " ++
1138 new_pkgs <- setDynFlags dflags'
1140 -- if the package flags changed, we should reset the context
1141 -- and link the new packages.
1142 dflags <- getDynFlags
1143 when (packageFlags dflags /= pkg_flags) $ do
1144 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1145 session <- getSession
1146 io (GHC.setTargets session [])
1147 io (GHC.load session LoadAllTargets)
1148 io (linkPackages dflags new_pkgs)
1149 setContextAfterLoad session []
1153 unsetOptions :: String -> GHCi ()
1155 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1156 let opts = words str
1157 (minus_opts, rest1) = partition isMinus opts
1158 (plus_opts, rest2) = partition isPlus rest1
1160 if (not (null rest2))
1161 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1164 mapM_ unsetOpt plus_opts
1166 -- can't do GHC flags for now
1167 if (not (null minus_opts))
1168 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1171 isMinus ('-':s) = True
1174 isPlus ('+':s) = True
1178 = case strToGHCiOpt str of
1179 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1180 Just o -> setOption o
1183 = case strToGHCiOpt str of
1184 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1185 Just o -> unsetOption o
1187 strToGHCiOpt :: String -> (Maybe GHCiOption)
1188 strToGHCiOpt "s" = Just ShowTiming
1189 strToGHCiOpt "t" = Just ShowType
1190 strToGHCiOpt "r" = Just RevertCAFs
1191 strToGHCiOpt _ = Nothing
1193 optToStr :: GHCiOption -> String
1194 optToStr ShowTiming = "s"
1195 optToStr ShowType = "t"
1196 optToStr RevertCAFs = "r"
1198 -- ---------------------------------------------------------------------------
1203 ["modules" ] -> showModules
1204 ["bindings"] -> showBindings
1205 ["linker"] -> io showLinkerState
1206 ["breaks"] -> showBkptTable
1207 ["context"] -> showContext
1208 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1211 session <- getSession
1212 let show_one ms = do m <- io (GHC.showModule session ms)
1214 graph <- io (GHC.getModuleGraph session)
1215 mapM_ show_one graph
1219 unqual <- io (GHC.getPrintUnqual s)
1220 bindings <- io (GHC.getBindings s)
1221 mapM_ showTyThing bindings
1224 showTyThing (AnId id) = do
1225 ty' <- cleanType (GHC.idType id)
1226 printForUser $ ppr id <> text " :: " <> ppr ty'
1227 showTyThing _ = return ()
1229 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1230 cleanType :: Type -> GHCi Type
1232 dflags <- getDynFlags
1233 if dopt Opt_GlasgowExts dflags
1235 else return $! GHC.dropForAlls ty
1237 showBkptTable :: GHCi ()
1239 activeBreaks <- getActiveBreakPoints
1240 printForUser $ ppr activeBreaks
1242 showContext :: GHCi ()
1245 printForUser $ vcat (map pp_resume (resume st))
1247 pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1249 -- -----------------------------------------------------------------------------
1252 completeNone :: String -> IO [String]
1253 completeNone w = return []
1256 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1257 completeWord w start end = do
1258 line <- Readline.getLineBuffer
1260 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1262 | Just c <- is_cmd line -> do
1263 maybe_cmd <- lookupCommand c
1264 let (n,w') = selectWord (words' 0 line)
1266 Nothing -> return Nothing
1267 Just (_,_,False,complete) -> wrapCompleter complete w
1268 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1269 return (map (drop n) rets)
1270 in wrapCompleter complete' w'
1272 --printf "complete %s, start = %d, end = %d\n" w start end
1273 wrapCompleter completeIdentifier w
1274 where words' _ [] = []
1275 words' n str = let (w,r) = break isSpace str
1276 (s,r') = span isSpace r
1277 in (n,w):words' (n+length w+length s) r'
1278 -- In a Haskell expression we want to parse 'a-b' as three words
1279 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1280 -- only be a single word.
1281 selectWord [] = (0,w)
1282 selectWord ((offset,x):xs)
1283 | offset+length x >= start = (start-offset,take (end-offset) x)
1284 | otherwise = selectWord xs
1287 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1288 | otherwise = Nothing
1291 cmds <- readIORef commands
1292 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1294 completeMacro w = do
1295 cmds <- readIORef commands
1296 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1297 return (filter (w `isPrefixOf`) cmds')
1299 completeIdentifier w = do
1301 rdrs <- GHC.getRdrNamesInScope s
1302 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1304 completeModule w = do
1306 dflags <- GHC.getSessionDynFlags s
1307 let pkg_mods = allExposedModules dflags
1308 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1310 completeHomeModule w = do
1312 g <- GHC.getModuleGraph s
1313 let home_mods = map GHC.ms_mod_name g
1314 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1316 completeSetOptions w = do
1317 return (filter (w `isPrefixOf`) options)
1318 where options = "args":"prog":allFlags
1320 completeFilename = Readline.filenameCompletionFunction
1322 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1324 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1325 unionComplete f1 f2 w = do
1330 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1331 wrapCompleter fun w = do
1334 [] -> return Nothing
1335 [x] -> return (Just (x,[]))
1336 xs -> case getCommonPrefix xs of
1337 "" -> return (Just ("",xs))
1338 pref -> return (Just (pref,xs))
1340 getCommonPrefix :: [String] -> String
1341 getCommonPrefix [] = ""
1342 getCommonPrefix (s:ss) = foldl common s ss
1343 where common s "" = ""
1345 common (c:cs) (d:ds)
1346 | c == d = c : common cs ds
1349 allExposedModules :: DynFlags -> [ModuleName]
1350 allExposedModules dflags
1351 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1353 pkg_db = pkgIdMap (pkgState dflags)
1355 completeCmd = completeNone
1356 completeMacro = completeNone
1357 completeIdentifier = completeNone
1358 completeModule = completeNone
1359 completeHomeModule = completeNone
1360 completeSetOptions = completeNone
1361 completeFilename = completeNone
1362 completeHomeModuleOrFile=completeNone
1363 completeBkpt = completeNone
1366 -- ---------------------------------------------------------------------------
1367 -- User code exception handling
1369 -- This is the exception handler for exceptions generated by the
1370 -- user's code and exceptions coming from children sessions;
1371 -- it normally just prints out the exception. The
1372 -- handler must be recursive, in case showing the exception causes
1373 -- more exceptions to be raised.
1375 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1376 -- raising another exception. We therefore don't put the recursive
1377 -- handler arond the flushing operation, so if stderr is closed
1378 -- GHCi will just die gracefully rather than going into an infinite loop.
1379 handler :: Exception -> GHCi Bool
1381 handler exception = do
1383 io installSignalHandlers
1384 ghciHandle handler (showException exception >> return False)
1386 showException (DynException dyn) =
1387 case fromDynamic dyn of
1388 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1389 Just Interrupted -> io (putStrLn "Interrupted.")
1390 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1391 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1392 Just other_ghc_ex -> io (print other_ghc_ex)
1394 showException other_exception
1395 = io (putStrLn ("*** Exception: " ++ show other_exception))
1397 -----------------------------------------------------------------------------
1398 -- recursive exception handlers
1400 -- Don't forget to unblock async exceptions in the handler, or if we're
1401 -- in an exception loop (eg. let a = error a in a) the ^C exception
1402 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1404 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1405 ghciHandle h (GHCi m) = GHCi $ \s ->
1406 Exception.catch (m s)
1407 (\e -> unGHCi (ghciUnblock (h e)) s)
1409 ghciUnblock :: GHCi a -> GHCi a
1410 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1413 -- ----------------------------------------------------------------------------
1416 expandPath :: String -> GHCi String
1418 case dropWhile isSpace path of
1420 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1421 return (tilde ++ '/':d)
1425 -- ----------------------------------------------------------------------------
1426 -- Windows console setup
1428 setUpConsole :: IO ()
1430 #ifdef mingw32_HOST_OS
1431 -- On Windows we need to set a known code page, otherwise the characters
1432 -- we read from the console will be be in some strange encoding, and
1433 -- similarly for characters we write to the console.
1435 -- At the moment, GHCi pretends all input is Latin-1. In the
1436 -- future we should support UTF-8, but for now we set the code pages
1439 -- It seems you have to set the font in the console window to
1440 -- a Unicode font in order for output to work properly,
1441 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1442 -- (see MSDN for SetConsoleOutputCP()).
1444 setConsoleCP 28591 -- ISO Latin-1
1445 setConsoleOutputCP 28591 -- ISO Latin-1
1449 -- commands for debugger
1450 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1452 stepCmd :: String -> GHCi Bool
1453 stepCmd [] = doContinue setStepFlag
1454 stepCmd expression = do
1456 runCommand expression
1458 continueCmd :: String -> GHCi Bool
1459 continueCmd [] = doContinue $ return ()
1460 continueCmd other = do
1461 io $ putStrLn "The continue command accepts no arguments."
1464 doContinue :: IO () -> GHCi Bool
1465 doContinue actionBeforeCont = do
1466 resumeAction <- popResume
1467 case resumeAction of
1469 io $ putStrLn "There is no computation running."
1471 Just (_,_,handle) -> do
1472 io $ actionBeforeCont
1473 session <- getSession
1474 runResult <- io $ GHC.resume session handle
1475 names <- switchOnRunResult runResult
1476 finishEvalExpr names
1479 deleteCmd :: String -> GHCi Bool
1480 deleteCmd argLine = do
1481 deleteSwitch $ words argLine
1484 deleteSwitch :: [String] -> GHCi ()
1486 io $ putStrLn "The delete command requires at least one argument."
1487 -- delete all break points
1488 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1489 deleteSwitch idents = do
1490 mapM_ deleteOneBreak idents
1492 deleteOneBreak :: String -> GHCi ()
1494 | all isDigit str = deleteBreak (read str)
1495 | otherwise = return ()
1497 -- handle the "break" command
1498 breakCmd :: String -> GHCi Bool
1499 breakCmd argLine = do
1500 session <- getSession
1501 breakSwitch session $ words argLine
1504 breakSwitch :: Session -> [String] -> GHCi ()
1505 breakSwitch _session [] = do
1506 io $ putStrLn "The break command requires at least one argument."
1507 breakSwitch session args@(arg1:rest)
1508 | looksLikeModuleName arg1 = do
1509 mod <- wantInterpretedModule session arg1
1510 breakByModule session mod rest
1511 | all isDigit arg1 = do
1512 (toplevel, _) <- io $ GHC.getContext session
1514 (mod : _) -> breakByModuleLine mod (read arg1) rest
1516 io $ putStrLn "Cannot find default module for breakpoint."
1517 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1518 | otherwise = do -- assume it's a name
1519 names <- io $ GHC.parseName session arg1
1523 let loc = nameSrcLoc n
1525 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1526 if not is_interpreted
1527 then noCanDo $ text "module " <> ppr modl <>
1528 text " is not interpreted"
1531 then findBreakAndSet (nameModule n) $
1532 findBreakByCoord (srcLocLine loc, srcLocCol loc)
1533 else noCanDo $ text "can't find its location: " <>
1536 noCanDo why = printForUser $
1537 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1540 wantInterpretedModule :: Session -> String -> GHCi Module
1541 wantInterpretedModule session str = do
1542 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1543 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1544 when (not is_interpreted) $
1545 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1548 breakByModule :: Session -> Module -> [String] -> GHCi ()
1549 breakByModule session mod args@(arg1:rest)
1550 | all isDigit arg1 = do -- looks like a line number
1551 breakByModuleLine mod (read arg1) rest
1552 | otherwise = io $ putStrLn "Invalid arguments to :break"
1554 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1555 breakByModuleLine mod line args
1556 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1557 | [col] <- args, all isDigit col =
1558 findBreakAndSet mod $ findBreakByCoord (line, read col)
1559 | otherwise = io $ putStrLn "Invalid arguments to :break"
1561 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1562 findBreakAndSet mod lookupTickTree = do
1563 tickArray <- getTickArray mod
1564 (breakArray, _) <- getModBreak mod
1565 case lookupTickTree tickArray of
1566 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1567 Just (tick, span) -> do
1568 success <- io $ setBreakFlag True breakArray tick
1569 session <- getSession
1573 recordBreak $ BreakLocation
1579 text "Breakpoint " <> ppr nm <>
1581 then text " was already set at " <> ppr span
1582 else text " activated at " <> ppr span
1584 printForUser $ text "Breakpoint could not be activated at"
1587 -- When a line number is specified, the current policy for choosing
1588 -- the best breakpoint is this:
1589 -- - the leftmost complete subexpression on the specified line, or
1590 -- - the leftmost subexpression starting on the specified line, or
1591 -- - the rightmost subexpression enclosing the specified line
1593 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1594 findBreakByLine line arr
1595 | not (inRange (bounds arr) line) = Nothing
1597 listToMaybe (sortBy leftmost complete) `mplus`
1598 listToMaybe (sortBy leftmost incomplete) `mplus`
1599 listToMaybe (sortBy rightmost ticks)
1603 starts_here = [ tick | tick@(nm,span) <- ticks,
1604 srcSpanStartLine span == line ]
1606 (complete,incomplete) = partition ends_here starts_here
1607 where ends_here (nm,span) = srcSpanEndLine span == line
1609 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1610 findBreakByCoord (line, col) arr
1611 | not (inRange (bounds arr) line) = Nothing
1613 listToMaybe (sortBy rightmost contains)
1617 -- the ticks that span this coordinate
1618 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1620 leftmost (_,a) (_,b) = a `compare` b
1621 rightmost (_,a) (_,b) = b `compare` a
1623 spans :: SrcSpan -> (Int,Int) -> Bool
1624 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1625 where loc = mkSrcLoc (srcSpanFile span) l c
1628 -- --------------------------------------------------------------------------
1631 getTickArray :: Module -> GHCi TickArray
1632 getTickArray modl = do
1634 let arrmap = tickarrays st
1635 case lookupModuleEnv arrmap modl of
1636 Just arr -> return arr
1638 (breakArray, ticks) <- getModBreak modl
1639 let arr = mkTickArray (assocs ticks)
1640 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1643 discardTickArrays :: GHCi ()
1644 discardTickArrays = do
1646 setGHCiState st{tickarrays = emptyModuleEnv}
1648 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1650 = accumArray (flip (:)) [] (1, max_line)
1651 [ (line, (nm,span)) | (nm,span) <- ticks,
1652 line <- srcSpanLines span ]
1654 max_line = maximum (map srcSpanEndLine (map snd ticks))
1655 srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1657 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1658 getModBreak mod = do
1659 session <- getSession
1660 Just mod_info <- io $ GHC.getModuleInfo session mod
1661 let modBreaks = GHC.modInfoModBreaks mod_info
1662 let array = GHC.modBreaks_flags modBreaks
1663 let ticks = GHC.modBreaks_locs modBreaks
1664 return (array, ticks)
1666 lookupModule :: Session -> String -> GHCi Module
1667 lookupModule session modName
1668 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1670 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1671 setBreakFlag toggle array index
1672 | toggle = GHC.setBreakOn array index
1673 | otherwise = GHC.setBreakOff array index
1676 {- these should probably go to the GHC API at some point -}
1677 enableBreakPoint :: Session -> Module -> Int -> IO ()
1678 enableBreakPoint session mod index = return ()
1680 disableBreakPoint :: Session -> Module -> Int -> IO ()
1681 disableBreakPoint session mod index = return ()
1683 activeBreakPoints :: Session -> IO [(Module,Int)]
1684 activeBreakPoints session = return []
1686 enableSingleStep :: Session -> IO ()
1687 enableSingleStep session = return ()
1689 disableSingleStep :: Session -> IO ()
1690 disableSingleStep session = return ()