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 )
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 ("browse", keepGoing browseCmd, False, completeModule),
108 ("cd", keepGoing changeDirectory, False, completeFilename),
109 ("check", keepGoing checkModule, False, completeHomeModule),
110 ("continue", continueCmd, False, completeNone),
111 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
112 ("def", keepGoing defineMacro, False, completeIdentifier),
113 ("delete", keepGoing deleteCmd, False, completeNone),
114 ("e", keepGoing editFile, False, completeFilename),
115 ("edit", keepGoing editFile, False, completeFilename),
116 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
117 ("force", keepGoing forceCmd, False, completeIdentifier),
118 ("help", keepGoing help, False, completeNone),
119 ("info", keepGoing info, False, completeIdentifier),
120 ("kind", keepGoing kindOfType, False, completeIdentifier),
121 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
122 ("list", keepGoing listCmd, False, completeNone),
123 ("module", keepGoing setContext, False, completeModule),
124 ("main", keepGoing runMain, False, completeIdentifier),
125 ("print", keepGoing printCmd, False, completeIdentifier),
126 ("quit", quit, False, completeNone),
127 ("reload", keepGoing reloadModule, False, completeNone),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
131 ("step", stepCmd, False, completeIdentifier),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("undef", keepGoing undefineMacro, False, completeMacro),
134 ("unset", keepGoing unsetOptions, True, completeSetOptions)
137 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
138 keepGoing a str = a str >> return False
140 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoingPaths a str = a (toArgs str) >> return False
143 shortHelpText = "use :? for help.\n"
146 " Commands available from the prompt:\n" ++
148 " <stmt> evaluate/run <stmt>\n" ++
149 " :add <filename> ... add module(s) to the current target set\n" ++
150 " :abandon at a breakpoint, abandon current computation\n" ++
151 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
152 " :break <name> set a breakpoint on the specified function\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :continue resume after a breakpoint\n" ++
156 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :delete <number> delete the specified breakpoint\n" ++
159 " :delete * delete all breakpoints\n" ++
160 " :edit <file> edit file\n" ++
161 " :edit edit last module\n" ++
162 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
163 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
164 " :help, :? display this list of commands\n" ++
165 " :info [<name> ...] display information about the given names\n" ++
166 " :kind <type> show the kind of <type>\n" ++
167 " :load <filename> ... load module(s) and their dependents\n" ++
168 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
169 " :main [<arguments> ...] run the main function with the given arguments\n" ++
170 " :print [<name> ...] prints a value without forcing its computation\n" ++
171 " :quit exit GHCi\n" ++
172 " :reload reload the current module set\n" ++
174 " :set <option> ... set options\n" ++
175 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
176 " :set prog <progname> set the value returned by System.getProgName\n" ++
177 " :set prompt <prompt> set the prompt used in GHCi\n" ++
178 " :set editor <cmd> set the command used for :edit\n" ++
179 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
181 " :show breaks show active breakpoints\n" ++
182 " :show context show the breakpoint context\n" ++
183 " :show modules show the currently loaded modules\n" ++
184 " :show bindings show the current bindings made at the prompt\n" ++
186 " :sprint [<name> ...] simplifed version of :print\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :type <expr> show the type of <expr>\n" ++
190 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
191 " :unset <option> ... unset options\n" ++
192 " :!<command> run the shell command <command>\n" ++
194 " Options for ':set' and ':unset':\n" ++
196 " +r revert top-level expressions after each evaluation\n" ++
197 " +s print timing/memory stats after each evaluation\n" ++
198 " +t print type after evaluation\n" ++
199 " -<flags> most GHC command line flags can also be set here\n" ++
200 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
202 -- Todo: add help for breakpoint commands here
208 win <- System.Win32.getWindowsDirectory
209 return (win `joinFileName` "notepad.exe")
214 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
215 interactiveUI session srcs maybe_expr = do
216 -- HACK! If we happen to get into an infinite loop (eg the user
217 -- types 'let x=x in x' at the prompt), then the thread will block
218 -- on a blackhole, and become unreachable during GC. The GC will
219 -- detect that it is unreachable and send it the NonTermination
220 -- exception. However, since the thread is unreachable, everything
221 -- it refers to might be finalized, including the standard Handles.
222 -- This sounds like a bug, but we don't have a good solution right
228 -- Initialise buffering for the *interpreted* I/O system
229 initInterpBuffering session
231 when (isNothing maybe_expr) $ do
232 -- Only for GHCi (not runghc and ghc -e):
233 -- Turn buffering off for the compiled program's stdout/stderr
235 -- Turn buffering off for GHCi's stdout
237 hSetBuffering stdout NoBuffering
238 -- We don't want the cmd line to buffer any input that might be
239 -- intended for the program, so unbuffer stdin.
240 hSetBuffering stdin NoBuffering
242 -- initial context is just the Prelude
243 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
244 GHC.setContext session [] [prel_mod]
248 Readline.setAttemptedCompletionFunction (Just completeWord)
249 --Readline.parseAndBind "set show-all-if-ambiguous 1"
251 let symbols = "!#$%&*+/<=>?@\\^|-~"
252 specials = "(),;[]`{}"
254 word_break_chars = spaces ++ specials ++ symbols
256 Readline.setBasicWordBreakCharacters word_break_chars
257 Readline.setCompleterWordBreakCharacters word_break_chars
260 default_editor <- findEditor
262 startGHCi (runGHCi srcs maybe_expr)
263 GHCiState{ progname = "<interactive>",
267 editor = default_editor,
271 breaks = emptyActiveBreakPoints,
272 tickarrays = emptyModuleEnv
276 Readline.resetTerminal Nothing
281 prel_name = GHC.mkModuleName "Prelude"
283 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
284 runGHCi paths maybe_expr = do
285 let read_dot_files = not opt_IgnoreDotGhci
287 when (read_dot_files) $ do
290 exists <- io (doesFileExist file)
292 dir_ok <- io (checkPerms ".")
293 file_ok <- io (checkPerms file)
294 when (dir_ok && file_ok) $ do
295 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
298 Right hdl -> fileLoop hdl False
300 when (read_dot_files) $ do
301 -- Read in $HOME/.ghci
302 either_dir <- io (IO.try (getEnv "HOME"))
306 cwd <- io (getCurrentDirectory)
307 when (dir /= cwd) $ do
308 let file = dir ++ "/.ghci"
309 ok <- io (checkPerms file)
311 either_hdl <- io (IO.try (openFile file ReadMode))
314 Right hdl -> fileLoop hdl False
316 -- Perform a :load for files given on the GHCi command line
317 -- When in -e mode, if the load fails then we want to stop
318 -- immediately rather than going on to evaluate the expression.
319 when (not (null paths)) $ do
320 ok <- ghciHandle (\e -> do showException e; return Failed) $
322 when (isJust maybe_expr && failed ok) $
323 io (exitWith (ExitFailure 1))
325 -- if verbosity is greater than 0, or we are connected to a
326 -- terminal, display the prompt in the interactive loop.
327 is_tty <- io (hIsTerminalDevice stdin)
328 dflags <- getDynFlags
329 let show_prompt = verbosity dflags > 0 || is_tty
334 #if defined(mingw32_HOST_OS)
335 -- The win32 Console API mutates the first character of
336 -- type-ahead when reading from it in a non-buffered manner. Work
337 -- around this by flushing the input buffer of type-ahead characters,
338 -- but only if stdin is available.
339 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
341 Left err | isDoesNotExistError err -> return ()
342 | otherwise -> io (ioError err)
343 Right () -> return ()
345 -- initialise the console if necessary
348 -- enter the interactive loop
349 interactiveLoop is_tty show_prompt
351 -- just evaluate the expression we were given
356 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
359 interactiveLoop is_tty show_prompt =
360 -- Ignore ^C exceptions caught here
361 ghciHandleDyn (\e -> case e of
363 #if defined(mingw32_HOST_OS)
366 interactiveLoop is_tty show_prompt
367 _other -> return ()) $
369 ghciUnblock $ do -- unblock necessary if we recursed from the
370 -- exception handler above.
372 -- read commands from stdin
376 else fileLoop stdin show_prompt
378 fileLoop stdin show_prompt
382 -- NOTE: We only read .ghci files if they are owned by the current user,
383 -- and aren't world writable. Otherwise, we could be accidentally
384 -- running code planted by a malicious third party.
386 -- Furthermore, We only read ./.ghci if . is owned by the current user
387 -- and isn't writable by anyone else. I think this is sufficient: we
388 -- don't need to check .. and ../.. etc. because "." always refers to
389 -- the same directory while a process is running.
391 checkPerms :: String -> IO Bool
393 #ifdef mingw32_HOST_OS
396 Util.handle (\_ -> return False) $ do
397 st <- getFileStatus name
399 if fileOwner st /= me then do
400 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
403 let mode = fileMode st
404 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
405 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
407 putStrLn $ "*** WARNING: " ++ name ++
408 " is writable by someone else, IGNORING!"
413 fileLoop :: Handle -> Bool -> GHCi ()
414 fileLoop hdl show_prompt = do
415 session <- getSession
416 (mod,imports) <- io (GHC.getContext session)
418 resumes <- io $ GHC.getResumeContext session
419 when show_prompt (io (putStr (mkPrompt mod imports resumes (prompt st))))
420 l <- io (IO.try (hGetLine hdl))
422 Left e | isEOFError e -> return ()
423 | InvalidArgument <- etype -> return ()
424 | otherwise -> io (ioError e)
425 where etype = ioeGetErrorType e
426 -- treat InvalidArgument in the same way as EOF:
427 -- this can happen if the user closed stdin, or
428 -- perhaps did getContents which closes stdin at
431 case removeSpaces l of
432 "" -> fileLoop hdl show_prompt
433 l -> do quit <- runCommand l
434 if quit then return () else fileLoop hdl show_prompt
436 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
437 stringLoop [] = return False
438 stringLoop (s:ss) = do
439 case removeSpaces s of
441 l -> do quit <- runCommand l
442 if quit then return True else stringLoop ss
444 mkPrompt toplevs exports resumes prompt
445 = showSDoc $ f prompt
447 f ('%':'s':xs) = perc_s <> f xs
448 f ('%':'%':xs) = char '%' <> f xs
449 f (x:xs) = char x <> f xs
453 | eval:rest <- resumes
454 = (if not (null rest) then text "... " else empty)
455 <> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt
460 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
461 hsep (map (ppr . GHC.moduleName) exports)
466 readlineLoop :: GHCi ()
468 session <- getSession
469 (mod,imports) <- io (GHC.getContext session)
471 saveSession -- for use by completion
473 resumes <- io $ GHC.getResumeContext session
474 l <- io (readline (mkPrompt mod imports resumes (prompt st))
475 `finally` setNonBlockingFD 0)
476 -- readline sometimes puts stdin into blocking mode,
477 -- so we need to put it back for the IO library
482 case removeSpaces l of
487 if quit then return () else readlineLoop
490 runCommand :: String -> GHCi Bool
491 runCommand c = ghciHandle handler (doCommand c)
493 doCommand (':' : command) = specialCommand command
495 = do timeIt $ runStmt stmt
498 -- This version is for the GHC command-line option -e. The only difference
499 -- from runCommand is that it catches the ExitException exception and
500 -- exits, rather than printing out the exception.
501 runCommandEval c = ghciHandle handleEval (doCommand c)
503 handleEval (ExitException code) = io (exitWith code)
504 handleEval e = do handler e
505 io (exitWith (ExitFailure 1))
507 doCommand (':' : command) = specialCommand command
509 = do r <- runStmt stmt
511 False -> io (exitWith (ExitFailure 1))
512 -- failure to run the command causes exit(1) for ghc -e.
515 runStmt :: String -> GHCi Bool
517 | null (filter (not.isSpace) stmt) = return False
519 = do st <- getGHCiState
520 session <- getSession
521 result <- io $ withProgName (progname st) $ withArgs (args st) $
522 GHC.runStmt session stmt
527 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
528 afterRunStmt run_result = do
529 mb_result <- switchOnRunResult run_result
531 -- possibly print the type and revert CAFs after evaluating an expression
532 show_types <- isOptionSet ShowType
533 session <- getSession
536 Just (is_break,names) ->
537 when (is_break || show_types) $
538 mapM_ (showTypeOfName session) names
541 io installSignalHandlers
542 b <- isOptionSet RevertCAFs
543 io (when b revertCAFs)
548 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
549 switchOnRunResult GHC.RunFailed = return Nothing
550 switchOnRunResult (GHC.RunException e) = throw e
551 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
552 switchOnRunResult (GHC.RunBreak threadId names info) = do
553 session <- getSession
554 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
555 let modBreaks = GHC.modInfoModBreaks mod_info
556 let ticks = GHC.modBreaks_locs modBreaks
558 -- display information about the breakpoint
559 let location = ticks ! GHC.breakInfo_number info
560 printForUser $ ptext SLIT("Stopped at") <+> ppr location
562 -- run the command set with ":set stop <cmd>"
566 return (Just (True,names))
569 showTypeOfName :: Session -> Name -> GHCi ()
570 showTypeOfName session n
571 = do maybe_tything <- io (GHC.lookupName session n)
572 case maybe_tything of
574 Just thing -> showTyThing thing
576 specialCommand :: String -> GHCi Bool
577 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
578 specialCommand str = do
579 let (cmd,rest) = break isSpace str
580 maybe_cmd <- io (lookupCommand cmd)
582 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
583 ++ shortHelpText) >> return False)
584 Just (_,f,_,_) -> f (dropWhile isSpace rest)
586 lookupCommand :: String -> IO (Maybe Command)
587 lookupCommand str = do
588 cmds <- readIORef commands
589 -- look for exact match first, then the first prefix match
590 case [ c | c <- cmds, str == cmdName c ] of
591 c:_ -> return (Just c)
592 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
594 c:_ -> return (Just c)
596 -----------------------------------------------------------------------------
599 help :: String -> GHCi ()
600 help _ = io (putStr helpText)
602 info :: String -> GHCi ()
603 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
604 info s = do { let names = words s
605 ; session <- getSession
606 ; dflags <- getDynFlags
607 ; let exts = dopt Opt_GlasgowExts dflags
608 ; mapM_ (infoThing exts session) names }
610 infoThing exts session str = io $ do
611 names <- GHC.parseName session str
612 let filtered = filterOutChildren names
613 mb_stuffs <- mapM (GHC.getInfo session) filtered
614 unqual <- GHC.getPrintUnqual session
615 putStrLn (showSDocForUser unqual $
616 vcat (intersperse (text "") $
617 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
619 -- Filter out names whose parent is also there Good
620 -- example is '[]', which is both a type and data
621 -- constructor in the same type
622 filterOutChildren :: [Name] -> [Name]
623 filterOutChildren names = filter (not . parent_is_there) names
624 where parent_is_there n
625 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
629 pprInfo exts (thing, fixity, insts)
630 = pprTyThingInContextLoc exts thing
631 $$ show_fixity fixity
632 $$ vcat (map GHC.pprInstance insts)
635 | fix == GHC.defaultFixity = empty
636 | otherwise = ppr fix <+> ppr (GHC.getName thing)
638 runMain :: String -> GHCi ()
640 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
641 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
644 addModule :: [FilePath] -> GHCi ()
646 io (revertCAFs) -- always revert CAFs on load/add.
647 files <- mapM expandPath files
648 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
649 session <- getSession
650 io (mapM_ (GHC.addTarget session) targets)
651 ok <- io (GHC.load session LoadAllTargets)
654 changeDirectory :: String -> GHCi ()
655 changeDirectory dir = do
656 session <- getSession
657 graph <- io (GHC.getModuleGraph session)
658 when (not (null graph)) $
659 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
660 io (GHC.setTargets session [])
661 io (GHC.load session LoadAllTargets)
662 setContextAfterLoad session []
663 io (GHC.workingDirectoryChanged session)
664 dir <- expandPath dir
665 io (setCurrentDirectory dir)
667 editFile :: String -> GHCi ()
670 -- find the name of the "topmost" file loaded
671 session <- getSession
672 graph0 <- io (GHC.getModuleGraph session)
673 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
674 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
675 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
676 Just file -> do_edit file
677 Nothing -> throwDyn (CmdLineError "unknown file name")
678 | otherwise = do_edit str
684 throwDyn (CmdLineError "editor not set, use :set editor")
685 io $ system (cmd ++ ' ':file)
688 defineMacro :: String -> GHCi ()
690 let (macro_name, definition) = break isSpace s
691 cmds <- io (readIORef commands)
693 then throwDyn (CmdLineError "invalid macro name")
695 if (macro_name `elem` map cmdName cmds)
696 then throwDyn (CmdLineError
697 ("command '" ++ macro_name ++ "' is already defined"))
700 -- give the expression a type signature, so we can be sure we're getting
701 -- something of the right type.
702 let new_expr = '(' : definition ++ ") :: String -> IO String"
704 -- compile the expression
706 maybe_hv <- io (GHC.compileExpr cms new_expr)
709 Just hv -> io (writeIORef commands --
710 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
712 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
714 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
715 stringLoop (lines str)
717 undefineMacro :: String -> GHCi ()
718 undefineMacro macro_name = do
719 cmds <- io (readIORef commands)
720 if (macro_name `elem` map cmdName builtin_commands)
721 then throwDyn (CmdLineError
722 ("command '" ++ macro_name ++ "' cannot be undefined"))
724 if (macro_name `notElem` map cmdName cmds)
725 then throwDyn (CmdLineError
726 ("command '" ++ macro_name ++ "' not defined"))
728 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
731 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
732 loadModule fs = timeIt (loadModule' fs)
734 loadModule_ :: [FilePath] -> GHCi ()
735 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
737 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
738 loadModule' files = do
739 session <- getSession
742 io (GHC.setTargets session [])
743 io (GHC.load session LoadAllTargets)
746 let (filenames, phases) = unzip files
747 exp_filenames <- mapM expandPath filenames
748 let files' = zip exp_filenames phases
749 targets <- io (mapM (uncurry GHC.guessTarget) files')
751 -- NOTE: we used to do the dependency anal first, so that if it
752 -- fails we didn't throw away the current set of modules. This would
753 -- require some re-working of the GHC interface, so we'll leave it
754 -- as a ToDo for now.
756 io (GHC.setTargets session targets)
757 ok <- io (GHC.load session LoadAllTargets)
761 checkModule :: String -> GHCi ()
763 let modl = GHC.mkModuleName m
764 session <- getSession
765 result <- io (GHC.checkModule session modl)
767 Nothing -> io $ putStrLn "Nothing"
768 Just r -> io $ putStrLn (showSDoc (
769 case GHC.checkedModuleInfo r of
770 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
772 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
774 (text "global names: " <+> ppr global) $$
775 (text "local names: " <+> ppr local)
777 afterLoad (successIf (isJust result)) session
779 reloadModule :: String -> GHCi ()
781 io (revertCAFs) -- always revert CAFs on reload.
782 session <- getSession
783 ok <- io (GHC.load session LoadAllTargets)
786 io (revertCAFs) -- always revert CAFs on reload.
787 session <- getSession
788 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
791 afterLoad ok session = do
792 io (revertCAFs) -- always revert CAFs on load.
794 discardActiveBreakPoints
795 graph <- io (GHC.getModuleGraph session)
796 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
797 setContextAfterLoad session graph'
798 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
800 setContextAfterLoad session [] = do
801 prel_mod <- getPrelude
802 io (GHC.setContext session [] [prel_mod])
803 setContextAfterLoad session ms = do
804 -- load a target if one is available, otherwise load the topmost module.
805 targets <- io (GHC.getTargets session)
806 case [ m | Just m <- map (findTarget ms) targets ] of
808 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
809 load_this (last graph')
814 = case filter (`matches` t) ms of
818 summary `matches` Target (TargetModule m) _
819 = GHC.ms_mod_name summary == m
820 summary `matches` Target (TargetFile f _) _
821 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
822 summary `matches` target
825 load_this summary | m <- GHC.ms_mod summary = do
826 b <- io (GHC.moduleIsInterpreted session m)
827 if b then io (GHC.setContext session [m] [])
829 prel_mod <- getPrelude
830 io (GHC.setContext session [] [prel_mod,m])
833 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
834 modulesLoadedMsg ok mods = do
835 dflags <- getDynFlags
836 when (verbosity dflags > 0) $ do
838 | null mods = text "none."
840 punctuate comma (map ppr mods)) <> text "."
843 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
845 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
848 typeOfExpr :: String -> GHCi ()
850 = do cms <- getSession
851 maybe_ty <- io (GHC.exprType cms str)
854 Just ty -> do ty' <- cleanType ty
855 printForUser $ text str <> text " :: " <> ppr ty'
857 kindOfType :: String -> GHCi ()
859 = do cms <- getSession
860 maybe_ty <- io (GHC.typeKind cms str)
863 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
865 quit :: String -> GHCi Bool
868 shellEscape :: String -> GHCi Bool
869 shellEscape str = io (system str >> return False)
871 -----------------------------------------------------------------------------
872 -- Browsing a module's contents
874 browseCmd :: String -> GHCi ()
877 ['*':m] | looksLikeModuleName m -> browseModule m False
878 [m] | looksLikeModuleName m -> browseModule m True
879 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
881 browseModule m exports_only = do
883 modl <- if exports_only then lookupModule s m
884 else wantInterpretedModule s m
886 -- Temporarily set the context to the module we're interested in,
887 -- just so we can get an appropriate PrintUnqualified
888 (as,bs) <- io (GHC.getContext s)
889 prel_mod <- getPrelude
890 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
891 else GHC.setContext s [modl] [])
892 unqual <- io (GHC.getPrintUnqual s)
893 io (GHC.setContext s as bs)
895 mb_mod_info <- io $ GHC.getModuleInfo s modl
897 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
900 | exports_only = GHC.modInfoExports mod_info
901 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
903 filtered = filterOutChildren names
905 things <- io $ mapM (GHC.lookupName s) filtered
907 dflags <- getDynFlags
908 let exts = dopt Opt_GlasgowExts dflags
909 io (putStrLn (showSDocForUser unqual (
910 vcat (map (pprTyThingInContext exts) (catMaybes things))
912 -- ToDo: modInfoInstances currently throws an exception for
913 -- package modules. When it works, we can do this:
914 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
916 -----------------------------------------------------------------------------
917 -- Setting the module context
920 | all sensible mods = fn mods
921 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
923 (fn, mods) = case str of
924 '+':stuff -> (addToContext, words stuff)
925 '-':stuff -> (removeFromContext, words stuff)
926 stuff -> (newContext, words stuff)
928 sensible ('*':m) = looksLikeModuleName m
929 sensible m = looksLikeModuleName m
931 separate :: Session -> [String] -> [Module] -> [Module]
932 -> GHCi ([Module],[Module])
933 separate session [] as bs = return (as,bs)
934 separate session (('*':str):ms) as bs = do
935 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
936 b <- io $ GHC.moduleIsInterpreted session m
937 if b then separate session ms (m:as) bs
938 else throwDyn (CmdLineError ("module '"
939 ++ GHC.moduleNameString (GHC.moduleName m)
940 ++ "' is not interpreted"))
941 separate session (str:ms) as bs = do
942 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
943 separate session ms as (m:bs)
945 newContext :: [String] -> GHCi ()
948 (as,bs) <- separate s strs [] []
949 prel_mod <- getPrelude
950 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
951 io $ GHC.setContext s as bs'
954 addToContext :: [String] -> GHCi ()
955 addToContext strs = do
957 (as,bs) <- io $ GHC.getContext s
959 (new_as,new_bs) <- separate s strs [] []
961 let as_to_add = new_as \\ (as ++ bs)
962 bs_to_add = new_bs \\ (as ++ bs)
964 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
967 removeFromContext :: [String] -> GHCi ()
968 removeFromContext strs = do
970 (as,bs) <- io $ GHC.getContext s
972 (as_to_remove,bs_to_remove) <- separate s strs [] []
974 let as' = as \\ (as_to_remove ++ bs_to_remove)
975 bs' = bs \\ (as_to_remove ++ bs_to_remove)
977 io $ GHC.setContext s as' bs'
979 ----------------------------------------------------------------------------
982 -- set options in the interpreter. Syntax is exactly the same as the
983 -- ghc command line, except that certain options aren't available (-C,
986 -- This is pretty fragile: most options won't work as expected. ToDo:
987 -- figure out which ones & disallow them.
989 setCmd :: String -> GHCi ()
991 = do st <- getGHCiState
992 let opts = options st
993 io $ putStrLn (showSDoc (
994 text "options currently set: " <>
997 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1000 = case toArgs str of
1001 ("args":args) -> setArgs args
1002 ("prog":prog) -> setProg prog
1003 ("prompt":prompt) -> setPrompt (after 6)
1004 ("editor":cmd) -> setEditor (after 6)
1005 ("stop":cmd) -> setStop (after 4)
1006 wds -> setOptions wds
1007 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1011 setGHCiState st{ args = args }
1015 setGHCiState st{ progname = prog }
1017 io (hPutStrLn stderr "syntax: :set prog <progname>")
1021 setGHCiState st{ editor = cmd }
1025 setGHCiState st{ stop = cmd }
1027 setPrompt value = do
1030 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1031 else setGHCiState st{ prompt = remQuotes value }
1033 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1037 do -- first, deal with the GHCi opts (+s, +t, etc.)
1038 let (plus_opts, minus_opts) = partition isPlus wds
1039 mapM_ setOpt plus_opts
1041 -- then, dynamic flags
1042 dflags <- getDynFlags
1043 let pkg_flags = packageFlags dflags
1044 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1046 if (not (null leftovers))
1047 then throwDyn (CmdLineError ("unrecognised flags: " ++
1051 new_pkgs <- setDynFlags dflags'
1053 -- if the package flags changed, we should reset the context
1054 -- and link the new packages.
1055 dflags <- getDynFlags
1056 when (packageFlags dflags /= pkg_flags) $ do
1057 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1058 session <- getSession
1059 io (GHC.setTargets session [])
1060 io (GHC.load session LoadAllTargets)
1061 io (linkPackages dflags new_pkgs)
1062 setContextAfterLoad session []
1066 unsetOptions :: String -> GHCi ()
1068 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1069 let opts = words str
1070 (minus_opts, rest1) = partition isMinus opts
1071 (plus_opts, rest2) = partition isPlus rest1
1073 if (not (null rest2))
1074 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1077 mapM_ unsetOpt plus_opts
1079 -- can't do GHC flags for now
1080 if (not (null minus_opts))
1081 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1084 isMinus ('-':s) = True
1087 isPlus ('+':s) = True
1091 = case strToGHCiOpt str of
1092 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1093 Just o -> setOption o
1096 = case strToGHCiOpt str of
1097 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1098 Just o -> unsetOption o
1100 strToGHCiOpt :: String -> (Maybe GHCiOption)
1101 strToGHCiOpt "s" = Just ShowTiming
1102 strToGHCiOpt "t" = Just ShowType
1103 strToGHCiOpt "r" = Just RevertCAFs
1104 strToGHCiOpt _ = Nothing
1106 optToStr :: GHCiOption -> String
1107 optToStr ShowTiming = "s"
1108 optToStr ShowType = "t"
1109 optToStr RevertCAFs = "r"
1111 -- ---------------------------------------------------------------------------
1116 ["modules" ] -> showModules
1117 ["bindings"] -> showBindings
1118 ["linker"] -> io showLinkerState
1119 ["breaks"] -> showBkptTable
1120 ["context"] -> showContext
1121 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1124 session <- getSession
1125 let show_one ms = do m <- io (GHC.showModule session ms)
1127 graph <- io (GHC.getModuleGraph session)
1128 mapM_ show_one graph
1132 unqual <- io (GHC.getPrintUnqual s)
1133 bindings <- io (GHC.getBindings s)
1134 mapM_ showTyThing bindings
1137 showTyThing (AnId id) = do
1138 ty' <- cleanType (GHC.idType id)
1139 printForUser $ ppr id <> text " :: " <> ppr ty'
1140 showTyThing _ = return ()
1142 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1143 cleanType :: Type -> GHCi Type
1145 dflags <- getDynFlags
1146 if dopt Opt_GlasgowExts dflags
1148 else return $! GHC.dropForAlls ty
1150 showBkptTable :: GHCi ()
1152 activeBreaks <- getActiveBreakPoints
1153 printForUser $ ppr activeBreaks
1155 showContext :: GHCi ()
1157 session <- getSession
1158 resumes <- io $ GHC.getResumeContext session
1159 printForUser $ vcat (map pp_resume (reverse resumes))
1162 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1163 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1166 -- -----------------------------------------------------------------------------
1169 completeNone :: String -> IO [String]
1170 completeNone w = return []
1173 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1174 completeWord w start end = do
1175 line <- Readline.getLineBuffer
1177 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1179 | Just c <- is_cmd line -> do
1180 maybe_cmd <- lookupCommand c
1181 let (n,w') = selectWord (words' 0 line)
1183 Nothing -> return Nothing
1184 Just (_,_,False,complete) -> wrapCompleter complete w
1185 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1186 return (map (drop n) rets)
1187 in wrapCompleter complete' w'
1189 --printf "complete %s, start = %d, end = %d\n" w start end
1190 wrapCompleter completeIdentifier w
1191 where words' _ [] = []
1192 words' n str = let (w,r) = break isSpace str
1193 (s,r') = span isSpace r
1194 in (n,w):words' (n+length w+length s) r'
1195 -- In a Haskell expression we want to parse 'a-b' as three words
1196 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1197 -- only be a single word.
1198 selectWord [] = (0,w)
1199 selectWord ((offset,x):xs)
1200 | offset+length x >= start = (start-offset,take (end-offset) x)
1201 | otherwise = selectWord xs
1204 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1205 | otherwise = Nothing
1208 cmds <- readIORef commands
1209 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1211 completeMacro w = do
1212 cmds <- readIORef commands
1213 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1214 return (filter (w `isPrefixOf`) cmds')
1216 completeIdentifier w = do
1218 rdrs <- GHC.getRdrNamesInScope s
1219 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1221 completeModule w = do
1223 dflags <- GHC.getSessionDynFlags s
1224 let pkg_mods = allExposedModules dflags
1225 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1227 completeHomeModule w = do
1229 g <- GHC.getModuleGraph s
1230 let home_mods = map GHC.ms_mod_name g
1231 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1233 completeSetOptions w = do
1234 return (filter (w `isPrefixOf`) options)
1235 where options = "args":"prog":allFlags
1237 completeFilename = Readline.filenameCompletionFunction
1239 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1241 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1242 unionComplete f1 f2 w = do
1247 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1248 wrapCompleter fun w = do
1251 [] -> return Nothing
1252 [x] -> return (Just (x,[]))
1253 xs -> case getCommonPrefix xs of
1254 "" -> return (Just ("",xs))
1255 pref -> return (Just (pref,xs))
1257 getCommonPrefix :: [String] -> String
1258 getCommonPrefix [] = ""
1259 getCommonPrefix (s:ss) = foldl common s ss
1260 where common s "" = ""
1262 common (c:cs) (d:ds)
1263 | c == d = c : common cs ds
1266 allExposedModules :: DynFlags -> [ModuleName]
1267 allExposedModules dflags
1268 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1270 pkg_db = pkgIdMap (pkgState dflags)
1272 completeCmd = completeNone
1273 completeMacro = completeNone
1274 completeIdentifier = completeNone
1275 completeModule = completeNone
1276 completeHomeModule = completeNone
1277 completeSetOptions = completeNone
1278 completeFilename = completeNone
1279 completeHomeModuleOrFile=completeNone
1280 completeBkpt = completeNone
1283 -- ---------------------------------------------------------------------------
1284 -- User code exception handling
1286 -- This is the exception handler for exceptions generated by the
1287 -- user's code and exceptions coming from children sessions;
1288 -- it normally just prints out the exception. The
1289 -- handler must be recursive, in case showing the exception causes
1290 -- more exceptions to be raised.
1292 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1293 -- raising another exception. We therefore don't put the recursive
1294 -- handler arond the flushing operation, so if stderr is closed
1295 -- GHCi will just die gracefully rather than going into an infinite loop.
1296 handler :: Exception -> GHCi Bool
1298 handler exception = do
1300 io installSignalHandlers
1301 ghciHandle handler (showException exception >> return False)
1303 showException (DynException dyn) =
1304 case fromDynamic dyn of
1305 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1306 Just Interrupted -> io (putStrLn "Interrupted.")
1307 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1308 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1309 Just other_ghc_ex -> io (print other_ghc_ex)
1311 showException other_exception
1312 = io (putStrLn ("*** Exception: " ++ show other_exception))
1314 -----------------------------------------------------------------------------
1315 -- recursive exception handlers
1317 -- Don't forget to unblock async exceptions in the handler, or if we're
1318 -- in an exception loop (eg. let a = error a in a) the ^C exception
1319 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1321 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1322 ghciHandle h (GHCi m) = GHCi $ \s ->
1323 Exception.catch (m s)
1324 (\e -> unGHCi (ghciUnblock (h e)) s)
1326 ghciUnblock :: GHCi a -> GHCi a
1327 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1330 -- ----------------------------------------------------------------------------
1333 expandPath :: String -> GHCi String
1335 case dropWhile isSpace path of
1337 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1338 return (tilde ++ '/':d)
1342 -- ----------------------------------------------------------------------------
1343 -- Windows console setup
1345 setUpConsole :: IO ()
1347 #ifdef mingw32_HOST_OS
1348 -- On Windows we need to set a known code page, otherwise the characters
1349 -- we read from the console will be be in some strange encoding, and
1350 -- similarly for characters we write to the console.
1352 -- At the moment, GHCi pretends all input is Latin-1. In the
1353 -- future we should support UTF-8, but for now we set the code pages
1356 -- It seems you have to set the font in the console window to
1357 -- a Unicode font in order for output to work properly,
1358 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1359 -- (see MSDN for SetConsoleOutputCP()).
1361 setConsoleCP 28591 -- ISO Latin-1
1362 setConsoleOutputCP 28591 -- ISO Latin-1
1366 -- -----------------------------------------------------------------------------
1367 -- commands for debugger
1369 sprintCmd = pprintCommand False False
1370 printCmd = pprintCommand True False
1371 forceCmd = pprintCommand False True
1373 pprintCommand bind force str = do
1374 session <- getSession
1375 io $ pprintClosureCommand session bind force str
1377 stepCmd :: String -> GHCi Bool
1378 stepCmd [] = doContinue True
1379 stepCmd expression = do
1380 runCommand expression
1382 continueCmd :: String -> GHCi Bool
1383 continueCmd [] = doContinue False
1384 continueCmd other = do
1385 io $ putStrLn "The continue command accepts no arguments."
1388 doContinue :: Bool -> GHCi Bool
1389 doContinue step = do
1390 session <- getSession
1391 let resume | step = GHC.stepResume
1392 | otherwise = GHC.resume
1393 runResult <- io $ resume session
1394 afterRunStmt runResult
1397 abandonCmd :: String -> GHCi ()
1400 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1401 when (not b) $ io $ putStrLn "There is no computation running."
1404 io $ putStrLn "The abandon command accepts no arguments."
1406 deleteCmd :: String -> GHCi ()
1407 deleteCmd argLine = do
1408 deleteSwitch $ words argLine
1410 deleteSwitch :: [String] -> GHCi ()
1412 io $ putStrLn "The delete command requires at least one argument."
1413 -- delete all break points
1414 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1415 deleteSwitch idents = do
1416 mapM_ deleteOneBreak idents
1418 deleteOneBreak :: String -> GHCi ()
1420 | all isDigit str = deleteBreak (read str)
1421 | otherwise = return ()
1423 -- handle the "break" command
1424 breakCmd :: String -> GHCi ()
1425 breakCmd argLine = do
1426 session <- getSession
1427 breakSwitch session $ words argLine
1429 breakSwitch :: Session -> [String] -> GHCi ()
1430 breakSwitch _session [] = do
1431 io $ putStrLn "The break command requires at least one argument."
1432 breakSwitch session args@(arg1:rest)
1433 | looksLikeModuleName arg1 = do
1434 mod <- wantInterpretedModule session arg1
1435 breakByModule session mod rest
1436 | all isDigit arg1 = do
1437 (toplevel, _) <- io $ GHC.getContext session
1439 (mod : _) -> breakByModuleLine mod (read arg1) rest
1441 io $ putStrLn "Cannot find default module for breakpoint."
1442 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1443 | otherwise = do -- assume it's a name
1444 names <- io $ GHC.parseName session arg1
1448 let loc = GHC.nameSrcLoc n
1449 modl = GHC.nameModule n
1450 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1451 if not is_interpreted
1452 then noCanDo $ text "module " <> ppr modl <>
1453 text " is not interpreted"
1455 if GHC.isGoodSrcLoc loc
1456 then findBreakAndSet (GHC.nameModule n) $
1457 findBreakByCoord (Just (GHC.srcLocFile loc))
1458 (GHC.srcLocLine loc,
1460 else noCanDo $ text "can't find its location: " <>
1463 noCanDo why = printForUser $
1464 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1467 wantInterpretedModule :: Session -> String -> GHCi Module
1468 wantInterpretedModule session str = do
1469 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1470 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1471 when (not is_interpreted) $
1472 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1475 breakByModule :: Session -> Module -> [String] -> GHCi ()
1476 breakByModule session mod args@(arg1:rest)
1477 | all isDigit arg1 = do -- looks like a line number
1478 breakByModuleLine mod (read arg1) rest
1479 | otherwise = io $ putStrLn "Invalid arguments to :break"
1481 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1482 breakByModuleLine mod line args
1483 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1484 | [col] <- args, all isDigit col =
1485 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1486 | otherwise = io $ putStrLn "Invalid arguments to :break"
1488 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1489 findBreakAndSet mod lookupTickTree = do
1490 tickArray <- getTickArray mod
1491 (breakArray, _) <- getModBreak mod
1492 case lookupTickTree tickArray of
1493 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1494 Just (tick, span) -> do
1495 success <- io $ setBreakFlag True breakArray tick
1496 session <- getSession
1500 recordBreak $ BreakLocation
1506 text "Breakpoint " <> ppr nm <>
1508 then text " was already set at " <> ppr span
1509 else text " activated at " <> ppr span
1511 printForUser $ text "Breakpoint could not be activated at"
1514 -- When a line number is specified, the current policy for choosing
1515 -- the best breakpoint is this:
1516 -- - the leftmost complete subexpression on the specified line, or
1517 -- - the leftmost subexpression starting on the specified line, or
1518 -- - the rightmost subexpression enclosing the specified line
1520 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1521 findBreakByLine line arr
1522 | not (inRange (bounds arr) line) = Nothing
1524 listToMaybe (sortBy leftmost_largest complete) `mplus`
1525 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1526 listToMaybe (sortBy rightmost ticks)
1530 starts_here = [ tick | tick@(nm,span) <- ticks,
1531 GHC.srcSpanStartLine span == line ]
1533 (complete,incomplete) = partition ends_here starts_here
1534 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1536 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1537 -> Maybe (BreakIndex,SrcSpan)
1538 findBreakByCoord mb_file (line, col) arr
1539 | not (inRange (bounds arr) line) = Nothing
1541 listToMaybe (sortBy rightmost contains)
1545 -- the ticks that span this coordinate
1546 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1547 is_correct_file span ]
1549 is_correct_file span
1550 | Just f <- mb_file = GHC.srcSpanFile span == f
1554 leftmost_smallest (_,a) (_,b) = a `compare` b
1555 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1557 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1558 rightmost (_,a) (_,b) = b `compare` a
1560 spans :: SrcSpan -> (Int,Int) -> Bool
1561 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1562 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1564 start_bold = BS.pack "\ESC[1m"
1565 end_bold = BS.pack "\ESC[0m"
1567 listCmd :: String -> GHCi ()
1569 session <- getSession
1570 resumes <- io $ GHC.getResumeContext session
1572 [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1573 eval:_ -> io $ listAround (GHC.resumeSpan eval) True
1575 -- | list a section of a source file around a particular SrcSpan.
1576 -- If the highlight flag is True, also highlight the span using
1577 -- start_bold/end_bold.
1578 listAround span do_highlight = do
1579 contents <- BS.readFile (unpackFS file)
1581 lines = BS.split '\n' contents
1582 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1583 drop (line1 - 1 - pad_before) $ lines
1584 fst_line = max 1 (line1 - pad_before)
1585 line_nos = [ fst_line .. ]
1587 highlighted | do_highlight = zipWith highlight line_nos these_lines
1588 | otherwise = these_lines
1590 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1591 prefixed = zipWith BS.append bs_line_nos highlighted
1593 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1595 file = GHC.srcSpanFile span
1596 line1 = GHC.srcSpanStartLine span
1597 col1 = GHC.srcSpanStartCol span
1598 line2 = GHC.srcSpanEndLine span
1599 col2 = GHC.srcSpanEndCol span
1601 pad_before | line1 == 1 = 0
1606 | no == line1 && no == line2
1607 = let (a,r) = BS.splitAt col1 line
1608 (b,c) = BS.splitAt (col2-col1) r
1610 BS.concat [a,start_bold,b,end_bold,c]
1612 = let (a,b) = BS.splitAt col1 line in
1613 BS.concat [a, start_bold, b]
1615 = let (a,b) = BS.splitAt col2 line in
1616 BS.concat [a, end_bold, b]
1619 -- --------------------------------------------------------------------------
1622 getTickArray :: Module -> GHCi TickArray
1623 getTickArray modl = do
1625 let arrmap = tickarrays st
1626 case lookupModuleEnv arrmap modl of
1627 Just arr -> return arr
1629 (breakArray, ticks) <- getModBreak modl
1630 let arr = mkTickArray (assocs ticks)
1631 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1634 discardTickArrays :: GHCi ()
1635 discardTickArrays = do
1637 setGHCiState st{tickarrays = emptyModuleEnv}
1639 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1641 = accumArray (flip (:)) [] (1, max_line)
1642 [ (line, (nm,span)) | (nm,span) <- ticks,
1643 line <- srcSpanLines span ]
1645 max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
1646 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1647 GHC.srcSpanEndLine span ]
1649 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1650 getModBreak mod = do
1651 session <- getSession
1652 Just mod_info <- io $ GHC.getModuleInfo session mod
1653 let modBreaks = GHC.modInfoModBreaks mod_info
1654 let array = GHC.modBreaks_flags modBreaks
1655 let ticks = GHC.modBreaks_locs modBreaks
1656 return (array, ticks)
1658 lookupModule :: Session -> String -> GHCi Module
1659 lookupModule session modName
1660 = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1662 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1663 setBreakFlag toggle array index
1664 | toggle = GHC.setBreakOn array index
1665 | otherwise = GHC.setBreakOff array index
1668 {- these should probably go to the GHC API at some point -}
1669 enableBreakPoint :: Session -> Module -> Int -> IO ()
1670 enableBreakPoint session mod index = return ()
1672 disableBreakPoint :: Session -> Module -> Int -> IO ()
1673 disableBreakPoint session mod index = return ()
1675 activeBreakPoints :: Session -> IO [(Module,Int)]
1676 activeBreakPoints session = return []
1678 enableSingleStep :: Session -> IO ()
1679 enableSingleStep session = return ()
1681 disableSingleStep :: Session -> IO ()
1682 disableSingleStep session = return ()