1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
22 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
23 Type, Module, ModuleName, TyThing(..), Phase,
24 BreakIndex, Name, SrcSpan )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
37 import FastString ( unpackFS )
44 #ifndef mingw32_HOST_OS
46 #if __GLASGOW_HASKELL__ > 504
50 import GHC.ConsoleHandler ( flushConsole )
51 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
52 import qualified System.Win32
56 import Control.Concurrent ( yield ) -- Used in readline loop
57 import System.Console.Readline as Readline
62 import Control.Exception as Exception
63 -- import Control.Concurrent
65 import qualified Data.ByteString.Char8 as BS
69 import System.Environment
70 import System.Exit ( exitWith, ExitCode(..) )
71 import System.Directory
73 import System.IO.Error as IO
77 import Control.Monad as Monad
79 import Foreign.StablePtr ( newStablePtr )
80 import GHC.Exts ( unsafeCoerce# )
81 import GHC.IOBase ( IOErrorType(InvalidArgument) )
83 import Data.IORef ( IORef, readIORef, writeIORef )
85 import System.Posix.Internals ( setNonBlockingFD )
87 -----------------------------------------------------------------------------
91 " / _ \\ /\\ /\\/ __(_)\n"++
92 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
93 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
94 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
96 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
99 GLOBAL_VAR(commands, builtin_commands, [Command])
101 builtin_commands :: [Command]
103 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
104 ("?", keepGoing help, False, completeNone),
105 ("add", keepGoingPaths addModule, False, completeFilename),
106 ("abandon", keepGoing abandonCmd, False, completeNone),
107 ("break", keepGoing 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", keepGoing deleteCmd, False, completeNone),
115 ("e", keepGoing editFile, False, completeFilename),
116 ("edit", keepGoing editFile, False, completeFilename),
117 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
118 ("force", keepGoing forceCmd, False, completeIdentifier),
119 ("help", keepGoing help, False, completeNone),
120 ("info", keepGoing info, False, completeIdentifier),
121 ("kind", keepGoing kindOfType, False, completeIdentifier),
122 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
123 ("list", keepGoing listCmd, False, completeNone),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("print", keepGoing printCmd, False, completeIdentifier),
127 ("quit", quit, False, completeNone),
128 ("reload", keepGoing reloadModule, False, completeNone),
129 ("set", keepGoing setCmd, True, completeSetOptions),
130 ("show", keepGoing showCmd, False, completeNone),
131 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
132 ("step", stepCmd, False, completeIdentifier),
133 ("type", keepGoing typeOfExpr, False, completeIdentifier),
134 ("undef", keepGoing undefineMacro, False, completeMacro),
135 ("unset", keepGoing unsetOptions, True, completeSetOptions)
138 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
139 keepGoing a str = a str >> return False
141 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoingPaths a str = a (toArgs str) >> return False
144 shortHelpText = "use :? for help.\n"
147 " Commands available from the prompt:\n" ++
149 " <stmt> evaluate/run <stmt>\n" ++
150 " :add <filename> ... add module(s) to the current target set\n" ++
151 " :abandon at a breakpoint, abandon current computation\n" ++
152 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
153 " :break <name> set a breakpoint on the specified function\n" ++
154 " :browse [*]<module> display the names defined by <module>\n" ++
155 " :cd <dir> change directory to <dir>\n" ++
156 " :continue resume after a breakpoint\n" ++
157 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
158 " :def <cmd> <expr> define a command :<cmd>\n" ++
159 " :delete <number> delete the specified breakpoint\n" ++
160 " :delete * delete all breakpoints\n" ++
161 " :edit <file> edit file\n" ++
162 " :edit edit last module\n" ++
163 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
164 -- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
165 " :help, :? display this list of commands\n" ++
166 " :info [<name> ...] display information about the given names\n" ++
167 " :kind <type> show the kind of <type>\n" ++
168 " :load <filename> ... load module(s) and their dependents\n" ++
169 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
170 " :main [<arguments> ...] run the main function with the given arguments\n" ++
171 " :print [<name> ...] prints a value without forcing its computation\n" ++
172 " :quit exit GHCi\n" ++
173 " :reload reload the current module set\n" ++
175 " :set <option> ... set options\n" ++
176 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
177 " :set prog <progname> set the value returned by System.getProgName\n" ++
178 " :set prompt <prompt> set the prompt used in GHCi\n" ++
179 " :set editor <cmd> set the command used for :edit\n" ++
180 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
182 " :show breaks show active breakpoints\n" ++
183 " :show context show the breakpoint context\n" ++
184 " :show modules show the currently loaded modules\n" ++
185 " :show bindings show the current bindings made at the prompt\n" ++
187 " :sprint [<name> ...] simplifed version of :print\n" ++
188 " :step single-step after stopping at a breakpoint\n"++
189 " :step <expr> single-step into <expr>\n"++
190 " :type <expr> show the type of <expr>\n" ++
191 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
192 " :unset <option> ... unset options\n" ++
193 " :!<command> run the shell command <command>\n" ++
195 " Options for ':set' and ':unset':\n" ++
197 " +r revert top-level expressions after each evaluation\n" ++
198 " +s print timing/memory stats after each evaluation\n" ++
199 " +t print type after evaluation\n" ++
200 " -<flags> most GHC command line flags can also be set here\n" ++
201 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
203 -- Todo: add help for breakpoint commands here
209 win <- System.Win32.getWindowsDirectory
210 return (win `joinFileName` "notepad.exe")
215 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
216 interactiveUI session srcs maybe_expr = do
217 -- HACK! If we happen to get into an infinite loop (eg the user
218 -- types 'let x=x in x' at the prompt), then the thread will block
219 -- on a blackhole, and become unreachable during GC. The GC will
220 -- detect that it is unreachable and send it the NonTermination
221 -- exception. However, since the thread is unreachable, everything
222 -- it refers to might be finalized, including the standard Handles.
223 -- This sounds like a bug, but we don't have a good solution right
229 -- Initialise buffering for the *interpreted* I/O system
230 initInterpBuffering session
232 when (isNothing maybe_expr) $ do
233 -- Only for GHCi (not runghc and ghc -e):
234 -- Turn buffering off for the compiled program's stdout/stderr
236 -- Turn buffering off for GHCi's stdout
238 hSetBuffering stdout NoBuffering
239 -- We don't want the cmd line to buffer any input that might be
240 -- intended for the program, so unbuffer stdin.
241 hSetBuffering stdin NoBuffering
243 -- initial context is just the Prelude
244 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
245 GHC.setContext session [] [prel_mod]
249 Readline.setAttemptedCompletionFunction (Just completeWord)
250 --Readline.parseAndBind "set show-all-if-ambiguous 1"
252 let symbols = "!#$%&*+/<=>?@\\^|-~"
253 specials = "(),;[]`{}"
255 word_break_chars = spaces ++ specials ++ symbols
257 Readline.setBasicWordBreakCharacters word_break_chars
258 Readline.setCompleterWordBreakCharacters word_break_chars
261 default_editor <- findEditor
263 startGHCi (runGHCi srcs maybe_expr)
264 GHCiState{ progname = "<interactive>",
268 editor = default_editor,
273 breaks = emptyActiveBreakPoints,
274 tickarrays = emptyModuleEnv
278 Readline.resetTerminal Nothing
283 prel_name = GHC.mkModuleName "Prelude"
285 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
286 runGHCi paths maybe_expr = do
287 let read_dot_files = not opt_IgnoreDotGhci
289 when (read_dot_files) $ do
292 exists <- io (doesFileExist file)
294 dir_ok <- io (checkPerms ".")
295 file_ok <- io (checkPerms file)
296 when (dir_ok && file_ok) $ do
297 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
300 Right hdl -> fileLoop hdl False
302 when (read_dot_files) $ do
303 -- Read in $HOME/.ghci
304 either_dir <- io (IO.try (getEnv "HOME"))
308 cwd <- io (getCurrentDirectory)
309 when (dir /= cwd) $ do
310 let file = dir ++ "/.ghci"
311 ok <- io (checkPerms file)
313 either_hdl <- io (IO.try (openFile file ReadMode))
316 Right hdl -> fileLoop hdl False
318 -- Perform a :load for files given on the GHCi command line
319 -- When in -e mode, if the load fails then we want to stop
320 -- immediately rather than going on to evaluate the expression.
321 when (not (null paths)) $ do
322 ok <- ghciHandle (\e -> do showException e; return Failed) $
324 when (isJust maybe_expr && failed ok) $
325 io (exitWith (ExitFailure 1))
327 -- if verbosity is greater than 0, or we are connected to a
328 -- terminal, display the prompt in the interactive loop.
329 is_tty <- io (hIsTerminalDevice stdin)
330 dflags <- getDynFlags
331 let show_prompt = verbosity dflags > 0 || is_tty
336 #if defined(mingw32_HOST_OS)
337 -- The win32 Console API mutates the first character of
338 -- type-ahead when reading from it in a non-buffered manner. Work
339 -- around this by flushing the input buffer of type-ahead characters,
340 -- but only if stdin is available.
341 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
343 Left err | isDoesNotExistError err -> return ()
344 | otherwise -> io (ioError err)
345 Right () -> return ()
347 -- initialise the console if necessary
350 -- enter the interactive loop
351 interactiveLoop is_tty show_prompt
353 -- just evaluate the expression we were given
358 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
361 interactiveLoop is_tty show_prompt =
362 -- Ignore ^C exceptions caught here
363 ghciHandleDyn (\e -> case e of
365 #if defined(mingw32_HOST_OS)
368 interactiveLoop is_tty show_prompt
369 _other -> return ()) $
371 ghciUnblock $ do -- unblock necessary if we recursed from the
372 -- exception handler above.
374 -- read commands from stdin
378 else fileLoop stdin show_prompt
380 fileLoop stdin show_prompt
384 -- NOTE: We only read .ghci files if they are owned by the current user,
385 -- and aren't world writable. Otherwise, we could be accidentally
386 -- running code planted by a malicious third party.
388 -- Furthermore, We only read ./.ghci if . is owned by the current user
389 -- and isn't writable by anyone else. I think this is sufficient: we
390 -- don't need to check .. and ../.. etc. because "." always refers to
391 -- the same directory while a process is running.
393 checkPerms :: String -> IO Bool
395 #ifdef mingw32_HOST_OS
398 Util.handle (\_ -> return False) $ do
399 st <- getFileStatus name
401 if fileOwner st /= me then do
402 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
405 let mode = fileMode st
406 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
407 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
409 putStrLn $ "*** WARNING: " ++ name ++
410 " is writable by someone else, IGNORING!"
415 fileLoop :: Handle -> Bool -> GHCi ()
416 fileLoop hdl show_prompt = do
417 session <- getSession
418 (mod,imports) <- io (GHC.getContext session)
420 when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st))))
421 l <- io (IO.try (hGetLine hdl))
423 Left e | isEOFError e -> return ()
424 | InvalidArgument <- etype -> return ()
425 | otherwise -> io (ioError e)
426 where etype = ioeGetErrorType e
427 -- treat InvalidArgument in the same way as EOF:
428 -- this can happen if the user closed stdin, or
429 -- perhaps did getContents which closes stdin at
432 case removeSpaces l of
433 "" -> fileLoop hdl show_prompt
434 l -> do quit <- runCommand l
435 if quit then return () else fileLoop hdl show_prompt
437 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
438 stringLoop [] = return False
439 stringLoop (s:ss) = do
440 case removeSpaces s of
442 l -> do quit <- runCommand l
443 if quit then return True else stringLoop ss
445 mkPrompt toplevs exports resumes prompt
446 = showSDoc $ f prompt
448 f ('%':'s':xs) = perc_s <> f xs
449 f ('%':'%':xs) = char '%' <> f xs
450 f (x:xs) = char x <> f xs
454 | (span,_,_):rest <- resumes
455 = (if not (null rest) then text "... " else empty)
456 <> brackets (ppr span) <+> modules_prompt
461 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
462 hsep (map (ppr . GHC.moduleName) exports)
467 readlineLoop :: GHCi ()
469 session <- getSession
470 (mod,imports) <- io (GHC.getContext session)
472 saveSession -- for use by completion
474 l <- io (readline (mkPrompt mod imports (resume st) (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 (do nms <- runStmt stmt; finishEvalExpr nms)
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 nms <- runStmt stmt
511 Nothing -> io (exitWith (ExitFailure 1))
512 -- failure to run the command causes exit(1) for ghc -e.
513 _ -> do finishEvalExpr nms
516 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
518 | null (filter (not.isSpace) stmt) = return (Just (False,[]))
520 = do st <- getGHCiState
521 session <- getSession
522 result <- io $ withProgName (progname st) $ withArgs (args st) $
523 GHC.runStmt session stmt
524 switchOnRunResult result
526 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
527 switchOnRunResult GHC.RunFailed = return Nothing
528 switchOnRunResult (GHC.RunException e) = throw e
529 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
530 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
531 session <- getSession
532 Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
533 let modBreaks = GHC.modInfoModBreaks mod_info
534 let ticks = GHC.modBreaks_locs modBreaks
536 -- display information about the breakpoint
537 let location = ticks ! GHC.breakInfo_number info
538 printForUser $ ptext SLIT("Stopped at") <+> ppr location
540 pushResume location threadId resume
542 -- run the command set with ":set stop <cmd>"
546 return (Just (True,names))
548 -- possibly print the type and revert CAFs after evaluating an expression
549 finishEvalExpr mb_names
550 = do show_types <- isOptionSet ShowType
551 session <- getSession
554 Just (is_break,names) ->
555 when (is_break || show_types) $
556 mapM_ (showTypeOfName session) names
559 io installSignalHandlers
560 b <- isOptionSet RevertCAFs
561 io (when b revertCAFs)
563 showTypeOfName :: Session -> Name -> GHCi ()
564 showTypeOfName session n
565 = do maybe_tything <- io (GHC.lookupName session n)
566 case maybe_tything of
568 Just thing -> showTyThing thing
570 specialCommand :: String -> GHCi Bool
571 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
572 specialCommand str = do
573 let (cmd,rest) = break isSpace str
574 maybe_cmd <- io (lookupCommand cmd)
576 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
577 ++ shortHelpText) >> return False)
578 Just (_,f,_,_) -> f (dropWhile isSpace rest)
580 lookupCommand :: String -> IO (Maybe Command)
581 lookupCommand str = do
582 cmds <- readIORef commands
583 -- look for exact match first, then the first prefix match
584 case [ c | c <- cmds, str == cmdName c ] of
585 c:_ -> return (Just c)
586 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
588 c:_ -> return (Just c)
590 -----------------------------------------------------------------------------
593 help :: String -> GHCi ()
594 help _ = io (putStr helpText)
596 info :: String -> GHCi ()
597 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
598 info s = do { let names = words s
599 ; session <- getSession
600 ; dflags <- getDynFlags
601 ; let exts = dopt Opt_GlasgowExts dflags
602 ; mapM_ (infoThing exts session) names }
604 infoThing exts session str = io $ do
605 names <- GHC.parseName session str
606 let filtered = filterOutChildren names
607 mb_stuffs <- mapM (GHC.getInfo session) filtered
608 unqual <- GHC.getPrintUnqual session
609 putStrLn (showSDocForUser unqual $
610 vcat (intersperse (text "") $
611 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
613 -- Filter out names whose parent is also there Good
614 -- example is '[]', which is both a type and data
615 -- constructor in the same type
616 filterOutChildren :: [Name] -> [Name]
617 filterOutChildren names = filter (not . parent_is_there) names
618 where parent_is_there n
619 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
623 pprInfo exts (thing, fixity, insts)
624 = pprTyThingInContextLoc exts thing
625 $$ show_fixity fixity
626 $$ vcat (map GHC.pprInstance insts)
629 | fix == GHC.defaultFixity = empty
630 | otherwise = ppr fix <+> ppr (GHC.getName thing)
632 runMain :: String -> GHCi ()
634 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
635 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
638 addModule :: [FilePath] -> GHCi ()
640 io (revertCAFs) -- always revert CAFs on load/add.
641 files <- mapM expandPath files
642 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
643 session <- getSession
644 io (mapM_ (GHC.addTarget session) targets)
645 ok <- io (GHC.load session LoadAllTargets)
648 changeDirectory :: String -> GHCi ()
649 changeDirectory dir = do
650 session <- getSession
651 graph <- io (GHC.getModuleGraph session)
652 when (not (null graph)) $
653 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
654 io (GHC.setTargets session [])
655 io (GHC.load session LoadAllTargets)
656 setContextAfterLoad session []
657 io (GHC.workingDirectoryChanged session)
658 dir <- expandPath dir
659 io (setCurrentDirectory dir)
661 editFile :: String -> GHCi ()
664 -- find the name of the "topmost" file loaded
665 session <- getSession
666 graph0 <- io (GHC.getModuleGraph session)
667 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
668 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
669 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
670 Just file -> do_edit file
671 Nothing -> throwDyn (CmdLineError "unknown file name")
672 | otherwise = do_edit str
678 throwDyn (CmdLineError "editor not set, use :set editor")
679 io $ system (cmd ++ ' ':file)
682 defineMacro :: String -> GHCi ()
684 let (macro_name, definition) = break isSpace s
685 cmds <- io (readIORef commands)
687 then throwDyn (CmdLineError "invalid macro name")
689 if (macro_name `elem` map cmdName cmds)
690 then throwDyn (CmdLineError
691 ("command '" ++ macro_name ++ "' is already defined"))
694 -- give the expression a type signature, so we can be sure we're getting
695 -- something of the right type.
696 let new_expr = '(' : definition ++ ") :: String -> IO String"
698 -- compile the expression
700 maybe_hv <- io (GHC.compileExpr cms new_expr)
703 Just hv -> io (writeIORef commands --
704 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
706 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
708 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
709 stringLoop (lines str)
711 undefineMacro :: String -> GHCi ()
712 undefineMacro macro_name = do
713 cmds <- io (readIORef commands)
714 if (macro_name `elem` map cmdName builtin_commands)
715 then throwDyn (CmdLineError
716 ("command '" ++ macro_name ++ "' cannot be undefined"))
718 if (macro_name `notElem` map cmdName cmds)
719 then throwDyn (CmdLineError
720 ("command '" ++ macro_name ++ "' not defined"))
722 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
725 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
726 loadModule fs = timeIt (loadModule' fs)
728 loadModule_ :: [FilePath] -> GHCi ()
729 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
731 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
732 loadModule' files = do
733 session <- getSession
736 io (GHC.setTargets session [])
737 io (GHC.load session LoadAllTargets)
740 let (filenames, phases) = unzip files
741 exp_filenames <- mapM expandPath filenames
742 let files' = zip exp_filenames phases
743 targets <- io (mapM (uncurry GHC.guessTarget) files')
745 -- NOTE: we used to do the dependency anal first, so that if it
746 -- fails we didn't throw away the current set of modules. This would
747 -- require some re-working of the GHC interface, so we'll leave it
748 -- as a ToDo for now.
750 io (GHC.setTargets session targets)
751 ok <- io (GHC.load session LoadAllTargets)
755 checkModule :: String -> GHCi ()
757 let modl = GHC.mkModuleName m
758 session <- getSession
759 result <- io (GHC.checkModule session modl)
761 Nothing -> io $ putStrLn "Nothing"
762 Just r -> io $ putStrLn (showSDoc (
763 case GHC.checkedModuleInfo r of
764 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
766 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
768 (text "global names: " <+> ppr global) $$
769 (text "local names: " <+> ppr local)
771 afterLoad (successIf (isJust result)) session
773 reloadModule :: String -> GHCi ()
775 io (revertCAFs) -- always revert CAFs on reload.
776 session <- getSession
777 ok <- io (GHC.load session LoadAllTargets)
780 io (revertCAFs) -- always revert CAFs on reload.
781 session <- getSession
782 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
785 afterLoad ok session = do
786 io (revertCAFs) -- always revert CAFs on load.
789 discardActiveBreakPoints
790 graph <- io (GHC.getModuleGraph session)
791 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
792 setContextAfterLoad session graph'
793 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
795 setContextAfterLoad session [] = do
796 prel_mod <- getPrelude
797 io (GHC.setContext session [] [prel_mod])
798 setContextAfterLoad session ms = do
799 -- load a target if one is available, otherwise load the topmost module.
800 targets <- io (GHC.getTargets session)
801 case [ m | Just m <- map (findTarget ms) targets ] of
803 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
804 load_this (last graph')
809 = case filter (`matches` t) ms of
813 summary `matches` Target (TargetModule m) _
814 = GHC.ms_mod_name summary == m
815 summary `matches` Target (TargetFile f _) _
816 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
817 summary `matches` target
820 load_this summary | m <- GHC.ms_mod summary = do
821 b <- io (GHC.moduleIsInterpreted session m)
822 if b then io (GHC.setContext session [m] [])
824 prel_mod <- getPrelude
825 io (GHC.setContext session [] [prel_mod,m])
828 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
829 modulesLoadedMsg ok mods = do
830 dflags <- getDynFlags
831 when (verbosity dflags > 0) $ do
833 | null mods = text "none."
835 punctuate comma (map ppr mods)) <> text "."
838 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
840 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
843 typeOfExpr :: String -> GHCi ()
845 = do cms <- getSession
846 maybe_ty <- io (GHC.exprType cms str)
849 Just ty -> do ty' <- cleanType ty
850 printForUser $ text str <> text " :: " <> ppr ty'
852 kindOfType :: String -> GHCi ()
854 = do cms <- getSession
855 maybe_ty <- io (GHC.typeKind cms str)
858 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
860 quit :: String -> GHCi Bool
863 shellEscape :: String -> GHCi Bool
864 shellEscape str = io (system str >> return False)
866 -----------------------------------------------------------------------------
867 -- Browsing a module's contents
869 browseCmd :: String -> GHCi ()
872 ['*':m] | looksLikeModuleName m -> browseModule m False
873 [m] | looksLikeModuleName m -> browseModule m True
874 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
876 browseModule m exports_only = do
878 modl <- if exports_only then lookupModule s m
879 else wantInterpretedModule s m
881 -- Temporarily set the context to the module we're interested in,
882 -- just so we can get an appropriate PrintUnqualified
883 (as,bs) <- io (GHC.getContext s)
884 prel_mod <- getPrelude
885 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
886 else GHC.setContext s [modl] [])
887 unqual <- io (GHC.getPrintUnqual s)
888 io (GHC.setContext s as bs)
890 mb_mod_info <- io $ GHC.getModuleInfo s modl
892 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
895 | exports_only = GHC.modInfoExports mod_info
896 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
898 filtered = filterOutChildren names
900 things <- io $ mapM (GHC.lookupName s) filtered
902 dflags <- getDynFlags
903 let exts = dopt Opt_GlasgowExts dflags
904 io (putStrLn (showSDocForUser unqual (
905 vcat (map (pprTyThingInContext exts) (catMaybes things))
907 -- ToDo: modInfoInstances currently throws an exception for
908 -- package modules. When it works, we can do this:
909 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
911 -----------------------------------------------------------------------------
912 -- Setting the module context
915 | all sensible mods = fn mods
916 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
918 (fn, mods) = case str of
919 '+':stuff -> (addToContext, words stuff)
920 '-':stuff -> (removeFromContext, words stuff)
921 stuff -> (newContext, words stuff)
923 sensible ('*':m) = looksLikeModuleName m
924 sensible m = looksLikeModuleName m
926 separate :: Session -> [String] -> [Module] -> [Module]
927 -> GHCi ([Module],[Module])
928 separate session [] as bs = return (as,bs)
929 separate session (('*':str):ms) as bs = do
930 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
931 b <- io $ GHC.moduleIsInterpreted session m
932 if b then separate session ms (m:as) bs
933 else throwDyn (CmdLineError ("module '"
934 ++ GHC.moduleNameString (GHC.moduleName m)
935 ++ "' is not interpreted"))
936 separate session (str:ms) as bs = do
937 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
938 separate session ms as (m:bs)
940 newContext :: [String] -> GHCi ()
943 (as,bs) <- separate s strs [] []
944 prel_mod <- getPrelude
945 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
946 io $ GHC.setContext s as bs'
949 addToContext :: [String] -> GHCi ()
950 addToContext strs = do
952 (as,bs) <- io $ GHC.getContext s
954 (new_as,new_bs) <- separate s strs [] []
956 let as_to_add = new_as \\ (as ++ bs)
957 bs_to_add = new_bs \\ (as ++ bs)
959 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
962 removeFromContext :: [String] -> GHCi ()
963 removeFromContext strs = do
965 (as,bs) <- io $ GHC.getContext s
967 (as_to_remove,bs_to_remove) <- separate s strs [] []
969 let as' = as \\ (as_to_remove ++ bs_to_remove)
970 bs' = bs \\ (as_to_remove ++ bs_to_remove)
972 io $ GHC.setContext s as' bs'
974 ----------------------------------------------------------------------------
977 -- set options in the interpreter. Syntax is exactly the same as the
978 -- ghc command line, except that certain options aren't available (-C,
981 -- This is pretty fragile: most options won't work as expected. ToDo:
982 -- figure out which ones & disallow them.
984 setCmd :: String -> GHCi ()
986 = do st <- getGHCiState
987 let opts = options st
988 io $ putStrLn (showSDoc (
989 text "options currently set: " <>
992 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
996 ("args":args) -> setArgs args
997 ("prog":prog) -> setProg prog
998 ("prompt":prompt) -> setPrompt (after 6)
999 ("editor":cmd) -> setEditor (after 6)
1000 ("stop":cmd) -> setStop (after 4)
1001 wds -> setOptions wds
1002 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1006 setGHCiState st{ args = args }
1010 setGHCiState st{ progname = prog }
1012 io (hPutStrLn stderr "syntax: :set prog <progname>")
1016 setGHCiState st{ editor = cmd }
1020 setGHCiState st{ stop = cmd }
1022 setPrompt value = do
1025 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1026 else setGHCiState st{ prompt = remQuotes value }
1028 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1032 do -- first, deal with the GHCi opts (+s, +t, etc.)
1033 let (plus_opts, minus_opts) = partition isPlus wds
1034 mapM_ setOpt plus_opts
1036 -- then, dynamic flags
1037 dflags <- getDynFlags
1038 let pkg_flags = packageFlags dflags
1039 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1041 if (not (null leftovers))
1042 then throwDyn (CmdLineError ("unrecognised flags: " ++
1046 new_pkgs <- setDynFlags dflags'
1048 -- if the package flags changed, we should reset the context
1049 -- and link the new packages.
1050 dflags <- getDynFlags
1051 when (packageFlags dflags /= pkg_flags) $ do
1052 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1053 session <- getSession
1054 io (GHC.setTargets session [])
1055 io (GHC.load session LoadAllTargets)
1056 io (linkPackages dflags new_pkgs)
1057 setContextAfterLoad session []
1061 unsetOptions :: String -> GHCi ()
1063 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1064 let opts = words str
1065 (minus_opts, rest1) = partition isMinus opts
1066 (plus_opts, rest2) = partition isPlus rest1
1068 if (not (null rest2))
1069 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1072 mapM_ unsetOpt plus_opts
1074 -- can't do GHC flags for now
1075 if (not (null minus_opts))
1076 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1079 isMinus ('-':s) = True
1082 isPlus ('+':s) = True
1086 = case strToGHCiOpt str of
1087 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1088 Just o -> setOption o
1091 = case strToGHCiOpt str of
1092 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1093 Just o -> unsetOption o
1095 strToGHCiOpt :: String -> (Maybe GHCiOption)
1096 strToGHCiOpt "s" = Just ShowTiming
1097 strToGHCiOpt "t" = Just ShowType
1098 strToGHCiOpt "r" = Just RevertCAFs
1099 strToGHCiOpt _ = Nothing
1101 optToStr :: GHCiOption -> String
1102 optToStr ShowTiming = "s"
1103 optToStr ShowType = "t"
1104 optToStr RevertCAFs = "r"
1106 -- ---------------------------------------------------------------------------
1111 ["modules" ] -> showModules
1112 ["bindings"] -> showBindings
1113 ["linker"] -> io showLinkerState
1114 ["breaks"] -> showBkptTable
1115 ["context"] -> showContext
1116 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
1119 session <- getSession
1120 let show_one ms = do m <- io (GHC.showModule session ms)
1122 graph <- io (GHC.getModuleGraph session)
1123 mapM_ show_one graph
1127 unqual <- io (GHC.getPrintUnqual s)
1128 bindings <- io (GHC.getBindings s)
1129 mapM_ showTyThing bindings
1132 showTyThing (AnId id) = do
1133 ty' <- cleanType (GHC.idType id)
1134 printForUser $ ppr id <> text " :: " <> ppr ty'
1135 showTyThing _ = return ()
1137 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1138 cleanType :: Type -> GHCi Type
1140 dflags <- getDynFlags
1141 if dopt Opt_GlasgowExts dflags
1143 else return $! GHC.dropForAlls ty
1145 showBkptTable :: GHCi ()
1147 activeBreaks <- getActiveBreakPoints
1148 printForUser $ ppr activeBreaks
1150 showContext :: GHCi ()
1153 printForUser $ vcat (map pp_resume (resume st))
1155 pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1157 -- -----------------------------------------------------------------------------
1160 completeNone :: String -> IO [String]
1161 completeNone w = return []
1164 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1165 completeWord w start end = do
1166 line <- Readline.getLineBuffer
1168 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1170 | Just c <- is_cmd line -> do
1171 maybe_cmd <- lookupCommand c
1172 let (n,w') = selectWord (words' 0 line)
1174 Nothing -> return Nothing
1175 Just (_,_,False,complete) -> wrapCompleter complete w
1176 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1177 return (map (drop n) rets)
1178 in wrapCompleter complete' w'
1180 --printf "complete %s, start = %d, end = %d\n" w start end
1181 wrapCompleter completeIdentifier w
1182 where words' _ [] = []
1183 words' n str = let (w,r) = break isSpace str
1184 (s,r') = span isSpace r
1185 in (n,w):words' (n+length w+length s) r'
1186 -- In a Haskell expression we want to parse 'a-b' as three words
1187 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1188 -- only be a single word.
1189 selectWord [] = (0,w)
1190 selectWord ((offset,x):xs)
1191 | offset+length x >= start = (start-offset,take (end-offset) x)
1192 | otherwise = selectWord xs
1195 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1196 | otherwise = Nothing
1199 cmds <- readIORef commands
1200 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1202 completeMacro w = do
1203 cmds <- readIORef commands
1204 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1205 return (filter (w `isPrefixOf`) cmds')
1207 completeIdentifier w = do
1209 rdrs <- GHC.getRdrNamesInScope s
1210 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1212 completeModule w = do
1214 dflags <- GHC.getSessionDynFlags s
1215 let pkg_mods = allExposedModules dflags
1216 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1218 completeHomeModule w = do
1220 g <- GHC.getModuleGraph s
1221 let home_mods = map GHC.ms_mod_name g
1222 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1224 completeSetOptions w = do
1225 return (filter (w `isPrefixOf`) options)
1226 where options = "args":"prog":allFlags
1228 completeFilename = Readline.filenameCompletionFunction
1230 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1232 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1233 unionComplete f1 f2 w = do
1238 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1239 wrapCompleter fun w = do
1242 [] -> return Nothing
1243 [x] -> return (Just (x,[]))
1244 xs -> case getCommonPrefix xs of
1245 "" -> return (Just ("",xs))
1246 pref -> return (Just (pref,xs))
1248 getCommonPrefix :: [String] -> String
1249 getCommonPrefix [] = ""
1250 getCommonPrefix (s:ss) = foldl common s ss
1251 where common s "" = ""
1253 common (c:cs) (d:ds)
1254 | c == d = c : common cs ds
1257 allExposedModules :: DynFlags -> [ModuleName]
1258 allExposedModules dflags
1259 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1261 pkg_db = pkgIdMap (pkgState dflags)
1263 completeCmd = completeNone
1264 completeMacro = completeNone
1265 completeIdentifier = completeNone
1266 completeModule = completeNone
1267 completeHomeModule = completeNone
1268 completeSetOptions = completeNone
1269 completeFilename = completeNone
1270 completeHomeModuleOrFile=completeNone
1271 completeBkpt = completeNone
1274 -- ---------------------------------------------------------------------------
1275 -- User code exception handling
1277 -- This is the exception handler for exceptions generated by the
1278 -- user's code and exceptions coming from children sessions;
1279 -- it normally just prints out the exception. The
1280 -- handler must be recursive, in case showing the exception causes
1281 -- more exceptions to be raised.
1283 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1284 -- raising another exception. We therefore don't put the recursive
1285 -- handler arond the flushing operation, so if stderr is closed
1286 -- GHCi will just die gracefully rather than going into an infinite loop.
1287 handler :: Exception -> GHCi Bool
1289 handler exception = do
1291 io installSignalHandlers
1292 ghciHandle handler (showException exception >> return False)
1294 showException (DynException dyn) =
1295 case fromDynamic dyn of
1296 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1297 Just Interrupted -> io (putStrLn "Interrupted.")
1298 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1299 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1300 Just other_ghc_ex -> io (print other_ghc_ex)
1302 showException other_exception
1303 = io (putStrLn ("*** Exception: " ++ show other_exception))
1305 -----------------------------------------------------------------------------
1306 -- recursive exception handlers
1308 -- Don't forget to unblock async exceptions in the handler, or if we're
1309 -- in an exception loop (eg. let a = error a in a) the ^C exception
1310 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1312 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1313 ghciHandle h (GHCi m) = GHCi $ \s ->
1314 Exception.catch (m s)
1315 (\e -> unGHCi (ghciUnblock (h e)) s)
1317 ghciUnblock :: GHCi a -> GHCi a
1318 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1321 -- ----------------------------------------------------------------------------
1324 expandPath :: String -> GHCi String
1326 case dropWhile isSpace path of
1328 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1329 return (tilde ++ '/':d)
1333 -- ----------------------------------------------------------------------------
1334 -- Windows console setup
1336 setUpConsole :: IO ()
1338 #ifdef mingw32_HOST_OS
1339 -- On Windows we need to set a known code page, otherwise the characters
1340 -- we read from the console will be be in some strange encoding, and
1341 -- similarly for characters we write to the console.
1343 -- At the moment, GHCi pretends all input is Latin-1. In the
1344 -- future we should support UTF-8, but for now we set the code pages
1347 -- It seems you have to set the font in the console window to
1348 -- a Unicode font in order for output to work properly,
1349 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1350 -- (see MSDN for SetConsoleOutputCP()).
1352 setConsoleCP 28591 -- ISO Latin-1
1353 setConsoleOutputCP 28591 -- ISO Latin-1
1357 -- -----------------------------------------------------------------------------
1358 -- commands for debugger
1360 sprintCmd = pprintCommand False False
1361 printCmd = pprintCommand True False
1362 forceCmd = pprintCommand False True
1364 pprintCommand bind force str = do
1365 session <- getSession
1366 io $ pprintClosureCommand session bind force str
1368 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1370 stepCmd :: String -> GHCi Bool
1371 stepCmd [] = doContinue setStepFlag
1372 stepCmd expression = do
1374 runCommand expression
1376 continueCmd :: String -> GHCi Bool
1377 continueCmd [] = doContinue $ return ()
1378 continueCmd other = do
1379 io $ putStrLn "The continue command accepts no arguments."
1382 doContinue :: IO () -> GHCi Bool
1383 doContinue actionBeforeCont = do
1384 resumeAction <- popResume
1385 case resumeAction of
1387 io $ putStrLn "There is no computation running."
1389 Just (_,_,handle) -> do
1390 io $ actionBeforeCont
1391 session <- getSession
1392 runResult <- io $ GHC.resume session handle
1393 names <- switchOnRunResult runResult
1394 finishEvalExpr names
1397 abandonCmd :: String -> GHCi ()
1402 io $ putStrLn "There is no computation running."
1405 -- the prompt will change to indicate the new context
1407 deleteCmd :: String -> GHCi ()
1408 deleteCmd argLine = do
1409 deleteSwitch $ words argLine
1411 deleteSwitch :: [String] -> GHCi ()
1413 io $ putStrLn "The delete command requires at least one argument."
1414 -- delete all break points
1415 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1416 deleteSwitch idents = do
1417 mapM_ deleteOneBreak idents
1419 deleteOneBreak :: String -> GHCi ()
1421 | all isDigit str = deleteBreak (read str)
1422 | otherwise = return ()
1424 -- handle the "break" command
1425 breakCmd :: String -> GHCi ()
1426 breakCmd argLine = do
1427 session <- getSession
1428 breakSwitch session $ words argLine
1430 breakSwitch :: Session -> [String] -> GHCi ()
1431 breakSwitch _session [] = do
1432 io $ putStrLn "The break command requires at least one argument."
1433 breakSwitch session args@(arg1:rest)
1434 | looksLikeModuleName arg1 = do
1435 mod <- wantInterpretedModule session arg1
1436 breakByModule session mod rest
1437 | all isDigit arg1 = do
1438 (toplevel, _) <- io $ GHC.getContext session
1440 (mod : _) -> breakByModuleLine mod (read arg1) rest
1442 io $ putStrLn "Cannot find default module for breakpoint."
1443 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1444 | otherwise = do -- assume it's a name
1445 names <- io $ GHC.parseName session arg1
1449 let loc = GHC.nameSrcLoc n
1450 modl = GHC.nameModule n
1451 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1452 if not is_interpreted
1453 then noCanDo $ text "module " <> ppr modl <>
1454 text " is not interpreted"
1456 if GHC.isGoodSrcLoc loc
1457 then findBreakAndSet (GHC.nameModule n) $
1458 findBreakByCoord (Just (GHC.srcLocFile loc))
1459 (GHC.srcLocLine loc,
1461 else noCanDo $ text "can't find its location: " <>
1464 noCanDo why = printForUser $
1465 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1468 wantInterpretedModule :: Session -> String -> GHCi Module
1469 wantInterpretedModule session str = do
1470 modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1471 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1472 when (not is_interpreted) $
1473 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1476 breakByModule :: Session -> Module -> [String] -> GHCi ()
1477 breakByModule session mod args@(arg1:rest)
1478 | all isDigit arg1 = do -- looks like a line number
1479 breakByModuleLine mod (read arg1) rest
1480 | otherwise = io $ putStrLn "Invalid arguments to :break"
1482 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1483 breakByModuleLine mod line args
1484 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1485 | [col] <- args, all isDigit col =
1486 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1487 | otherwise = io $ putStrLn "Invalid arguments to :break"
1489 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1490 findBreakAndSet mod lookupTickTree = do
1491 tickArray <- getTickArray mod
1492 (breakArray, _) <- getModBreak mod
1493 case lookupTickTree tickArray of
1494 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1495 Just (tick, span) -> do
1496 success <- io $ setBreakFlag True breakArray tick
1497 session <- getSession
1501 recordBreak $ BreakLocation
1507 text "Breakpoint " <> ppr nm <>
1509 then text " was already set at " <> ppr span
1510 else text " activated at " <> ppr span
1512 printForUser $ text "Breakpoint could not be activated at"
1515 -- When a line number is specified, the current policy for choosing
1516 -- the best breakpoint is this:
1517 -- - the leftmost complete subexpression on the specified line, or
1518 -- - the leftmost subexpression starting on the specified line, or
1519 -- - the rightmost subexpression enclosing the specified line
1521 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1522 findBreakByLine line arr
1523 | not (inRange (bounds arr) line) = Nothing
1525 listToMaybe (sortBy leftmost_largest complete) `mplus`
1526 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1527 listToMaybe (sortBy rightmost ticks)
1531 starts_here = [ tick | tick@(nm,span) <- ticks,
1532 GHC.srcSpanStartLine span == line ]
1534 (complete,incomplete) = partition ends_here starts_here
1535 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1537 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1538 -> Maybe (BreakIndex,SrcSpan)
1539 findBreakByCoord mb_file (line, col) arr
1540 | not (inRange (bounds arr) line) = Nothing
1542 listToMaybe (sortBy rightmost contains)
1546 -- the ticks that span this coordinate
1547 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1548 is_correct_file span ]
1550 is_correct_file span
1551 | Just f <- mb_file = GHC.srcSpanFile span == f
1555 leftmost_smallest (_,a) (_,b) = a `compare` b
1556 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1558 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1559 rightmost (_,a) (_,b) = b `compare` a
1561 spans :: SrcSpan -> (Int,Int) -> Bool
1562 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1563 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1565 start_bold = BS.pack "\ESC[1m"
1566 end_bold = BS.pack "\ESC[0m"
1568 listCmd :: String -> GHCi ()
1572 [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1573 (span,_,_):_ -> io $ listAround span 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 ()