1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
22 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
23 Type, Module, ModuleName, TyThing(..), Phase,
24 BreakIndex, Name, SrcSpan, Resume, SingleStep )
30 import Outputable hiding (printForUser)
31 import Module -- for ModuleEnv
33 -- Other random utilities
35 import BasicTypes hiding (isTopLevel)
36 import Panic hiding (showException)
43 #ifndef mingw32_HOST_OS
45 #if __GLASGOW_HASKELL__ > 504
49 import GHC.ConsoleHandler ( flushConsole )
50 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
51 import qualified System.Win32
55 import Control.Concurrent ( yield ) -- Used in readline loop
56 import System.Console.Readline as Readline
61 import Control.Exception as Exception
62 -- import Control.Concurrent
64 import qualified Data.ByteString.Char8 as BS
68 import System.Environment
69 import System.Exit ( exitWith, ExitCode(..) )
70 import System.Directory
72 import System.IO.Error as IO
76 import Control.Monad as Monad
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 ("back", keepGoing backCmd, False, completeNone),
109 ("browse", keepGoing browseCmd, False, completeModule),
110 ("cd", keepGoing changeDirectory, False, completeFilename),
111 ("check", keepGoing checkModule, False, completeHomeModule),
112 ("continue", keepGoing continueCmd, False, completeNone),
113 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
114 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
115 ("def", keepGoing defineMacro, False, completeIdentifier),
116 ("delete", keepGoing deleteCmd, False, completeNone),
117 ("e", keepGoing editFile, False, completeFilename),
118 ("edit", keepGoing editFile, False, completeFilename),
119 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
120 ("force", keepGoing forceCmd, False, completeIdentifier),
121 ("forward", keepGoing forwardCmd, False, completeNone),
122 ("help", keepGoing help, False, completeNone),
123 ("history", keepGoing historyCmd, False, completeNone),
124 ("info", keepGoing info, False, completeIdentifier),
125 ("kind", keepGoing kindOfType, False, completeIdentifier),
126 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
127 ("list", keepGoing listCmd, False, completeNone),
128 ("module", keepGoing setContext, False, completeModule),
129 ("main", keepGoing runMain, False, completeIdentifier),
130 ("print", keepGoing printCmd, False, completeIdentifier),
131 ("quit", quit, False, completeNone),
132 ("reload", keepGoing reloadModule, False, completeNone),
133 ("set", keepGoing setCmd, True, completeSetOptions),
134 ("show", keepGoing showCmd, False, completeNone),
135 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
136 ("step", keepGoing stepCmd, False, completeIdentifier),
137 ("type", keepGoing typeOfExpr, False, completeIdentifier),
138 ("trace", keepGoing traceCmd, False, completeIdentifier),
139 ("undef", keepGoing undefineMacro, False, completeMacro),
140 ("unset", keepGoing unsetOptions, True, completeSetOptions)
143 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
144 keepGoing a str = a str >> return False
146 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
147 keepGoingPaths a str = a (toArgs str) >> return False
149 shortHelpText = "use :? for help.\n"
152 " Commands available from the prompt:\n" ++
154 " <statement> evaluate/run <statement>\n" ++
155 " :add <filename> ... add module(s) to the current target set\n" ++
156 " :browse [*]<module> display the names defined by <module>\n" ++
157 " :cd <dir> change directory to <dir>\n" ++
158 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
159 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
160 " :def <cmd> <expr> define a command :<cmd>\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 " :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 " :quit exit GHCi\n" ++
171 " :reload reload the current module set\n" ++
172 " :type <expr> show the type of <expr>\n" ++
173 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
174 " :!<command> run the shell command <command>\n" ++
176 " -- Commands for debugging:\n" ++
178 " :abandon at a breakpoint, abandon current computation\n" ++
179 " :back go back in the history (after :trace)\n" ++
180 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
181 " :break <name> set a breakpoint on the specified function\n" ++
182 " :continue resume after a breakpoint\n" ++
183 " :delete <number> delete the specified breakpoint\n" ++
184 " :delete * delete all breakpoints\n" ++
185 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
186 " :forward go forward in the history (after :back)\n" ++
187 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
188 " :print [<name> ...] prints a value without forcing its computation\n" ++
189 " :sprint [<name> ...] simplifed version of :print\n" ++
190 " :step single-step after stopping at a breakpoint\n"++
191 " :step <expr> single-step into <expr>\n"++
192 " :trace trace after stopping at a breakpoint\n"++
193 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
196 " -- Commands for changing settings:\n" ++
198 " :set <option> ... set options\n" ++
199 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
200 " :set prog <progname> set the value returned by System.getProgName\n" ++
201 " :set prompt <prompt> set the prompt used in GHCi\n" ++
202 " :set editor <cmd> set the command used for :edit\n" ++
203 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
204 " :unset <option> ... unset options\n" ++
206 " Options for ':set' and ':unset':\n" ++
208 " +r revert top-level expressions after each evaluation\n" ++
209 " +s print timing/memory stats after each evaluation\n" ++
210 " +t print type after evaluation\n" ++
211 " -<flags> most GHC command line flags can also be set here\n" ++
212 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
214 " -- Commands for displaying information:\n" ++
216 " :show bindings show the current bindings made at the prompt\n" ++
217 " :show breaks show the active breakpoints\n" ++
218 " :show context show the breakpoint context\n" ++
219 " :show modules show the currently loaded modules\n" ++
220 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
227 win <- System.Win32.getWindowsDirectory
228 return (win `joinFileName` "notepad.exe")
233 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
234 interactiveUI session srcs maybe_expr = do
235 -- HACK! If we happen to get into an infinite loop (eg the user
236 -- types 'let x=x in x' at the prompt), then the thread will block
237 -- on a blackhole, and become unreachable during GC. The GC will
238 -- detect that it is unreachable and send it the NonTermination
239 -- exception. However, since the thread is unreachable, everything
240 -- it refers to might be finalized, including the standard Handles.
241 -- This sounds like a bug, but we don't have a good solution right
247 -- Initialise buffering for the *interpreted* I/O system
248 initInterpBuffering session
250 when (isNothing maybe_expr) $ do
251 -- Only for GHCi (not runghc and ghc -e):
252 -- Turn buffering off for the compiled program's stdout/stderr
254 -- Turn buffering off for GHCi's stdout
256 hSetBuffering stdout NoBuffering
257 -- We don't want the cmd line to buffer any input that might be
258 -- intended for the program, so unbuffer stdin.
259 hSetBuffering stdin NoBuffering
261 -- initial context is just the Prelude
262 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
263 GHC.setContext session [] [prel_mod]
267 Readline.setAttemptedCompletionFunction (Just completeWord)
268 --Readline.parseAndBind "set show-all-if-ambiguous 1"
270 let symbols = "!#$%&*+/<=>?@\\^|-~"
271 specials = "(),;[]`{}"
273 word_break_chars = spaces ++ specials ++ symbols
275 Readline.setBasicWordBreakCharacters word_break_chars
276 Readline.setCompleterWordBreakCharacters word_break_chars
279 default_editor <- findEditor
281 startGHCi (runGHCi srcs maybe_expr)
282 GHCiState{ progname = "<interactive>",
286 editor = default_editor,
292 tickarrays = emptyModuleEnv,
297 Readline.resetTerminal Nothing
302 prel_name = GHC.mkModuleName "Prelude"
304 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
305 runGHCi paths maybe_expr = do
306 let read_dot_files = not opt_IgnoreDotGhci
308 when (read_dot_files) $ do
311 exists <- io (doesFileExist file)
313 dir_ok <- io (checkPerms ".")
314 file_ok <- io (checkPerms file)
315 when (dir_ok && file_ok) $ do
316 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
319 Right hdl -> fileLoop hdl False
321 when (read_dot_files) $ do
322 -- Read in $HOME/.ghci
323 either_dir <- io (IO.try (getEnv "HOME"))
327 cwd <- io (getCurrentDirectory)
328 when (dir /= cwd) $ do
329 let file = dir ++ "/.ghci"
330 ok <- io (checkPerms file)
332 either_hdl <- io (IO.try (openFile file ReadMode))
335 Right hdl -> fileLoop hdl False
337 -- Perform a :load for files given on the GHCi command line
338 -- When in -e mode, if the load fails then we want to stop
339 -- immediately rather than going on to evaluate the expression.
340 when (not (null paths)) $ do
341 ok <- ghciHandle (\e -> do showException e; return Failed) $
343 when (isJust maybe_expr && failed ok) $
344 io (exitWith (ExitFailure 1))
346 -- if verbosity is greater than 0, or we are connected to a
347 -- terminal, display the prompt in the interactive loop.
348 is_tty <- io (hIsTerminalDevice stdin)
349 dflags <- getDynFlags
350 let show_prompt = verbosity dflags > 0 || is_tty
355 #if defined(mingw32_HOST_OS)
356 -- The win32 Console API mutates the first character of
357 -- type-ahead when reading from it in a non-buffered manner. Work
358 -- around this by flushing the input buffer of type-ahead characters,
359 -- but only if stdin is available.
360 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
362 Left err | isDoesNotExistError err -> return ()
363 | otherwise -> io (ioError err)
364 Right () -> return ()
366 -- initialise the console if necessary
369 -- enter the interactive loop
370 interactiveLoop is_tty show_prompt
372 -- just evaluate the expression we were given
377 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
380 interactiveLoop is_tty show_prompt =
381 -- Ignore ^C exceptions caught here
382 ghciHandleDyn (\e -> case e of
384 #if defined(mingw32_HOST_OS)
387 interactiveLoop is_tty show_prompt
388 _other -> return ()) $
390 ghciUnblock $ do -- unblock necessary if we recursed from the
391 -- exception handler above.
393 -- read commands from stdin
397 else fileLoop stdin show_prompt
399 fileLoop stdin show_prompt
403 -- NOTE: We only read .ghci files if they are owned by the current user,
404 -- and aren't world writable. Otherwise, we could be accidentally
405 -- running code planted by a malicious third party.
407 -- Furthermore, We only read ./.ghci if . is owned by the current user
408 -- and isn't writable by anyone else. I think this is sufficient: we
409 -- don't need to check .. and ../.. etc. because "." always refers to
410 -- the same directory while a process is running.
412 checkPerms :: String -> IO Bool
414 #ifdef mingw32_HOST_OS
417 Util.handle (\_ -> return False) $ do
418 st <- getFileStatus name
420 if fileOwner st /= me then do
421 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
424 let mode = fileMode st
425 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
426 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
428 putStrLn $ "*** WARNING: " ++ name ++
429 " is writable by someone else, IGNORING!"
434 fileLoop :: Handle -> Bool -> GHCi ()
435 fileLoop hdl show_prompt = do
436 when show_prompt $ do
439 l <- io (IO.try (hGetLine hdl))
441 Left e | isEOFError e -> return ()
442 | InvalidArgument <- etype -> return ()
443 | otherwise -> io (ioError e)
444 where etype = ioeGetErrorType e
445 -- treat InvalidArgument in the same way as EOF:
446 -- this can happen if the user closed stdin, or
447 -- perhaps did getContents which closes stdin at
450 case removeSpaces l of
451 "" -> fileLoop hdl show_prompt
452 l -> do quit <- runCommands l
453 if quit then return () else fileLoop hdl show_prompt
456 session <- getSession
457 (toplevs,exports) <- io (GHC.getContext session)
458 resumes <- io $ GHC.getResumeContext session
464 let ix = GHC.resumeHistoryIx r
466 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
468 let hist = GHC.resumeHistory r !! (ix-1)
469 span <- io $ GHC.getHistorySpan session hist
470 return (brackets (ppr (negate ix) <> char ':'
471 <+> ppr span) <> space)
473 dots | r:rs <- resumes, not (null rs) = text "... "
477 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
478 hsep (map (ppr . GHC.moduleName) exports)
480 deflt_prompt = dots <> context_bit <> modules_bit
482 f ('%':'s':xs) = deflt_prompt <> f xs
483 f ('%':'%':xs) = char '%' <> f xs
484 f (x:xs) = char x <> f xs
488 return (showSDoc (f (prompt st)))
492 readlineLoop :: GHCi ()
494 session <- getSession
495 (mod,imports) <- io (GHC.getContext session)
497 saveSession -- for use by completion
499 mb_span <- getCurrentBreakSpan
501 l <- io (readline prompt `finally` setNonBlockingFD 0)
502 -- readline sometimes puts stdin into blocking mode,
503 -- so we need to put it back for the IO library
508 case removeSpaces l of
512 quit <- runCommands l
513 if quit then return () else readlineLoop
516 runCommands :: String -> GHCi Bool
518 q <- ghciHandle handler (doCommand cmd)
519 if q then return True else runNext
525 c:cs -> do setGHCiState st{ cmdqueue = cs }
528 doCommand (':' : cmd) = specialCommand cmd
529 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
532 enqueueCommands :: [String] -> GHCi ()
533 enqueueCommands cmds = do
535 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
538 -- This version is for the GHC command-line option -e. The only difference
539 -- from runCommand is that it catches the ExitException exception and
540 -- exits, rather than printing out the exception.
541 runCommandEval c = ghciHandle handleEval (doCommand c)
543 handleEval (ExitException code) = io (exitWith code)
544 handleEval e = do handler e
545 io (exitWith (ExitFailure 1))
547 doCommand (':' : command) = specialCommand command
549 = do r <- runStmt stmt GHC.RunToCompletion
551 False -> io (exitWith (ExitFailure 1))
552 -- failure to run the command causes exit(1) for ghc -e.
555 runStmt :: String -> SingleStep -> GHCi Bool
557 | null (filter (not.isSpace) stmt) = return False
558 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
560 = do st <- getGHCiState
561 session <- getSession
562 result <- io $ withProgName (progname st) $ withArgs (args st) $
563 GHC.runStmt session stmt step
567 afterRunStmt :: GHC.RunResult -> GHCi Bool
568 -- False <=> the statement failed to compile
569 afterRunStmt (GHC.RunException e) = throw e
570 afterRunStmt run_result = do
571 session <- getSession
573 GHC.RunOk names -> do
574 show_types <- isOptionSet ShowType
575 when show_types $ mapM_ (showTypeOfName session) names
576 GHC.RunBreak _ names mb_info -> do
577 resumes <- io $ GHC.getResumeContext session
578 printForUser $ ptext SLIT("Stopped at") <+>
579 ppr (GHC.resumeSpan (head resumes))
580 mapM_ (showTypeOfName session) names
581 maybe (return ()) runBreakCmd mb_info
582 -- run the command set with ":set stop <cmd>"
584 enqueueCommands [stop st]
589 io installSignalHandlers
590 b <- isOptionSet RevertCAFs
591 io (when b revertCAFs)
593 return (case run_result of GHC.RunOk _ -> True; _ -> False)
595 runBreakCmd :: GHC.BreakInfo -> GHCi ()
596 runBreakCmd info = do
597 let mod = GHC.breakInfo_module info
598 nm = GHC.breakInfo_number info
600 case [ loc | (i,loc) <- breaks st,
601 breakModule loc == mod, breakTick loc == nm ] of
603 loc:_ | null cmd -> return ()
604 | otherwise -> do enqueueCommands [cmd]; return ()
605 where cmd = onBreakCmd loc
607 showTypeOfName :: Session -> Name -> GHCi ()
608 showTypeOfName session n
609 = do maybe_tything <- io (GHC.lookupName session n)
610 case maybe_tything of
612 Just thing -> showTyThing thing
614 specialCommand :: String -> GHCi Bool
615 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
616 specialCommand str = do
617 let (cmd,rest) = break isSpace str
618 maybe_cmd <- io (lookupCommand cmd)
620 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
621 ++ shortHelpText) >> return False)
622 Just (_,f,_,_) -> f (dropWhile isSpace rest)
624 lookupCommand :: String -> IO (Maybe Command)
625 lookupCommand str = do
626 cmds <- readIORef commands
627 -- look for exact match first, then the first prefix match
628 case [ c | c <- cmds, str == cmdName c ] of
629 c:_ -> return (Just c)
630 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
632 c:_ -> return (Just c)
635 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
636 getCurrentBreakSpan = do
637 session <- getSession
638 resumes <- io $ GHC.getResumeContext session
642 let ix = GHC.resumeHistoryIx r
644 then return (Just (GHC.resumeSpan r))
646 let hist = GHC.resumeHistory r !! (ix-1)
647 span <- io $ GHC.getHistorySpan session hist
650 -----------------------------------------------------------------------------
653 noArgs :: GHCi () -> String -> GHCi ()
655 noArgs m _ = io $ putStrLn "This command takes no arguments"
657 help :: String -> GHCi ()
658 help _ = io (putStr helpText)
660 info :: String -> GHCi ()
661 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
662 info s = do { let names = words s
663 ; session <- getSession
664 ; dflags <- getDynFlags
665 ; let exts = dopt Opt_GlasgowExts dflags
666 ; mapM_ (infoThing exts session) names }
668 infoThing exts session str = io $ do
669 names <- GHC.parseName session str
670 let filtered = filterOutChildren names
671 mb_stuffs <- mapM (GHC.getInfo session) filtered
672 unqual <- GHC.getPrintUnqual session
673 putStrLn (showSDocForUser unqual $
674 vcat (intersperse (text "") $
675 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
677 -- Filter out names whose parent is also there Good
678 -- example is '[]', which is both a type and data
679 -- constructor in the same type
680 filterOutChildren :: [Name] -> [Name]
681 filterOutChildren names = filter (not . parent_is_there) names
682 where parent_is_there n
683 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
687 pprInfo exts (thing, fixity, insts)
688 = pprTyThingInContextLoc exts thing
689 $$ show_fixity fixity
690 $$ vcat (map GHC.pprInstance insts)
693 | fix == GHC.defaultFixity = empty
694 | otherwise = ppr fix <+> ppr (GHC.getName thing)
696 runMain :: String -> GHCi ()
698 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
699 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
701 addModule :: [FilePath] -> GHCi ()
703 io (revertCAFs) -- always revert CAFs on load/add.
704 files <- mapM expandPath files
705 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
706 session <- getSession
707 io (mapM_ (GHC.addTarget session) targets)
708 ok <- io (GHC.load session LoadAllTargets)
711 changeDirectory :: String -> GHCi ()
712 changeDirectory dir = do
713 session <- getSession
714 graph <- io (GHC.getModuleGraph session)
715 when (not (null graph)) $
716 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
717 io (GHC.setTargets session [])
718 io (GHC.load session LoadAllTargets)
719 setContextAfterLoad session []
720 io (GHC.workingDirectoryChanged session)
721 dir <- expandPath dir
722 io (setCurrentDirectory dir)
724 editFile :: String -> GHCi ()
726 do file <- if null str then chooseEditFile else return str
730 $ throwDyn (CmdLineError "editor not set, use :set editor")
731 io $ system (cmd ++ ' ':file)
734 -- The user didn't specify a file so we pick one for them.
735 -- Our strategy is to pick the first module that failed to load,
736 -- or otherwise the first target.
738 -- XXX: Can we figure out what happened if the depndecy analysis fails
739 -- (e.g., because the porgrammeer mistyped the name of a module)?
740 -- XXX: Can we figure out the location of an error to pass to the editor?
741 -- XXX: if we could figure out the list of errors that occured during the
742 -- last load/reaload, then we could start the editor focused on the first
744 chooseEditFile :: GHCi String
746 do session <- getSession
747 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
749 graph <- io (GHC.getModuleGraph session)
750 failed_graph <- filterM hasFailed graph
751 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
753 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
756 case pick (order failed_graph) of
757 Just file -> return file
759 do targets <- io (GHC.getTargets session)
760 case msum (map fromTarget targets) of
761 Just file -> return file
762 Nothing -> throwDyn (CmdLineError "No files to edit.")
764 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
765 fromTarget _ = Nothing -- when would we get a module target?
767 defineMacro :: String -> GHCi ()
769 let (macro_name, definition) = break isSpace s
770 cmds <- io (readIORef commands)
772 then throwDyn (CmdLineError "invalid macro name")
774 if (macro_name `elem` map cmdName cmds)
775 then throwDyn (CmdLineError
776 ("command '" ++ macro_name ++ "' is already defined"))
779 -- give the expression a type signature, so we can be sure we're getting
780 -- something of the right type.
781 let new_expr = '(' : definition ++ ") :: String -> IO String"
783 -- compile the expression
785 maybe_hv <- io (GHC.compileExpr cms new_expr)
788 Just hv -> io (writeIORef commands --
789 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
791 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
793 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
794 enqueueCommands (lines str)
797 undefineMacro :: String -> GHCi ()
798 undefineMacro macro_name = do
799 cmds <- io (readIORef commands)
800 if (macro_name `elem` map cmdName builtin_commands)
801 then throwDyn (CmdLineError
802 ("command '" ++ macro_name ++ "' cannot be undefined"))
804 if (macro_name `notElem` map cmdName cmds)
805 then throwDyn (CmdLineError
806 ("command '" ++ macro_name ++ "' not defined"))
808 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
810 cmdCmd :: String -> GHCi ()
812 let expr = '(' : str ++ ") :: IO String"
813 session <- getSession
814 maybe_hv <- io (GHC.compileExpr session expr)
818 cmds <- io $ (unsafeCoerce# hv :: IO String)
819 enqueueCommands (lines cmds)
822 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
823 loadModule fs = timeIt (loadModule' fs)
825 loadModule_ :: [FilePath] -> GHCi ()
826 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
828 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
829 loadModule' files = do
830 session <- getSession
833 discardActiveBreakPoints
834 io (GHC.setTargets session [])
835 io (GHC.load session LoadAllTargets)
838 let (filenames, phases) = unzip files
839 exp_filenames <- mapM expandPath filenames
840 let files' = zip exp_filenames phases
841 targets <- io (mapM (uncurry GHC.guessTarget) files')
843 -- NOTE: we used to do the dependency anal first, so that if it
844 -- fails we didn't throw away the current set of modules. This would
845 -- require some re-working of the GHC interface, so we'll leave it
846 -- as a ToDo for now.
848 io (GHC.setTargets session targets)
849 doLoad session LoadAllTargets
851 checkModule :: String -> GHCi ()
853 let modl = GHC.mkModuleName m
854 session <- getSession
855 result <- io (GHC.checkModule session modl)
857 Nothing -> io $ putStrLn "Nothing"
858 Just r -> io $ putStrLn (showSDoc (
859 case GHC.checkedModuleInfo r of
860 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
862 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
864 (text "global names: " <+> ppr global) $$
865 (text "local names: " <+> ppr local)
867 afterLoad (successIf (isJust result)) session
869 reloadModule :: String -> GHCi ()
871 io (revertCAFs) -- always revert CAFs on reload.
872 discardActiveBreakPoints
873 session <- getSession
874 doLoad session $ if null m then LoadAllTargets
875 else LoadUpTo (GHC.mkModuleName m)
878 doLoad session howmuch = do
879 -- turn off breakpoints before we load: we can't turn them off later, because
880 -- the ModBreaks will have gone away.
881 discardActiveBreakPoints
882 ok <- io (GHC.load session howmuch)
886 afterLoad ok session = do
887 io (revertCAFs) -- always revert CAFs on load.
889 graph <- io (GHC.getModuleGraph session)
890 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
891 setContextAfterLoad session graph'
892 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
894 setContextAfterLoad session [] = do
895 prel_mod <- getPrelude
896 io (GHC.setContext session [] [prel_mod])
897 setContextAfterLoad session ms = do
898 -- load a target if one is available, otherwise load the topmost module.
899 targets <- io (GHC.getTargets session)
900 case [ m | Just m <- map (findTarget ms) targets ] of
902 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
903 load_this (last graph')
908 = case filter (`matches` t) ms of
912 summary `matches` Target (TargetModule m) _
913 = GHC.ms_mod_name summary == m
914 summary `matches` Target (TargetFile f _) _
915 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
916 summary `matches` target
919 load_this summary | m <- GHC.ms_mod summary = do
920 b <- io (GHC.moduleIsInterpreted session m)
921 if b then io (GHC.setContext session [m] [])
923 prel_mod <- getPrelude
924 io (GHC.setContext session [] [prel_mod,m])
927 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
928 modulesLoadedMsg ok mods = do
929 dflags <- getDynFlags
930 when (verbosity dflags > 0) $ do
932 | null mods = text "none."
934 punctuate comma (map ppr mods)) <> text "."
937 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
939 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
942 typeOfExpr :: String -> GHCi ()
944 = do cms <- getSession
945 maybe_ty <- io (GHC.exprType cms str)
948 Just ty -> do ty' <- cleanType ty
949 printForUser $ text str <> text " :: " <> ppr ty'
951 kindOfType :: String -> GHCi ()
953 = do cms <- getSession
954 maybe_ty <- io (GHC.typeKind cms str)
957 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
959 quit :: String -> GHCi Bool
962 shellEscape :: String -> GHCi Bool
963 shellEscape str = io (system str >> return False)
965 -----------------------------------------------------------------------------
966 -- Browsing a module's contents
968 browseCmd :: String -> GHCi ()
971 ['*':m] | looksLikeModuleName m -> browseModule m False
972 [m] | looksLikeModuleName m -> browseModule m True
973 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
975 browseModule m exports_only = do
977 modl <- if exports_only then lookupModule m
978 else wantInterpretedModule m
980 -- Temporarily set the context to the module we're interested in,
981 -- just so we can get an appropriate PrintUnqualified
982 (as,bs) <- io (GHC.getContext s)
983 prel_mod <- getPrelude
984 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
985 else GHC.setContext s [modl] [])
986 unqual <- io (GHC.getPrintUnqual s)
987 io (GHC.setContext s as bs)
989 mb_mod_info <- io $ GHC.getModuleInfo s modl
991 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
994 | exports_only = GHC.modInfoExports mod_info
995 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
997 filtered = filterOutChildren names
999 things <- io $ mapM (GHC.lookupName s) filtered
1001 dflags <- getDynFlags
1002 let exts = dopt Opt_GlasgowExts dflags
1003 io (putStrLn (showSDocForUser unqual (
1004 vcat (map (pprTyThingInContext exts) (catMaybes things))
1006 -- ToDo: modInfoInstances currently throws an exception for
1007 -- package modules. When it works, we can do this:
1008 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1010 -----------------------------------------------------------------------------
1011 -- Setting the module context
1014 | all sensible mods = fn mods
1015 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1017 (fn, mods) = case str of
1018 '+':stuff -> (addToContext, words stuff)
1019 '-':stuff -> (removeFromContext, words stuff)
1020 stuff -> (newContext, words stuff)
1022 sensible ('*':m) = looksLikeModuleName m
1023 sensible m = looksLikeModuleName m
1025 separate :: Session -> [String] -> [Module] -> [Module]
1026 -> GHCi ([Module],[Module])
1027 separate session [] as bs = return (as,bs)
1028 separate session (('*':str):ms) as bs = do
1029 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1030 b <- io $ GHC.moduleIsInterpreted session m
1031 if b then separate session ms (m:as) bs
1032 else throwDyn (CmdLineError ("module '"
1033 ++ GHC.moduleNameString (GHC.moduleName m)
1034 ++ "' is not interpreted"))
1035 separate session (str:ms) as bs = do
1036 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1037 separate session ms as (m:bs)
1039 newContext :: [String] -> GHCi ()
1040 newContext strs = do
1042 (as,bs) <- separate s strs [] []
1043 prel_mod <- getPrelude
1044 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1045 io $ GHC.setContext s as bs'
1048 addToContext :: [String] -> GHCi ()
1049 addToContext strs = do
1051 (as,bs) <- io $ GHC.getContext s
1053 (new_as,new_bs) <- separate s strs [] []
1055 let as_to_add = new_as \\ (as ++ bs)
1056 bs_to_add = new_bs \\ (as ++ bs)
1058 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1061 removeFromContext :: [String] -> GHCi ()
1062 removeFromContext strs = do
1064 (as,bs) <- io $ GHC.getContext s
1066 (as_to_remove,bs_to_remove) <- separate s strs [] []
1068 let as' = as \\ (as_to_remove ++ bs_to_remove)
1069 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1071 io $ GHC.setContext s as' bs'
1073 ----------------------------------------------------------------------------
1076 -- set options in the interpreter. Syntax is exactly the same as the
1077 -- ghc command line, except that certain options aren't available (-C,
1080 -- This is pretty fragile: most options won't work as expected. ToDo:
1081 -- figure out which ones & disallow them.
1083 setCmd :: String -> GHCi ()
1085 = do st <- getGHCiState
1086 let opts = options st
1087 io $ putStrLn (showSDoc (
1088 text "options currently set: " <>
1091 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1094 = case toArgs str of
1095 ("args":args) -> setArgs args
1096 ("prog":prog) -> setProg prog
1097 ("prompt":prompt) -> setPrompt (after 6)
1098 ("editor":cmd) -> setEditor (after 6)
1099 ("stop":cmd) -> setStop (after 4)
1100 wds -> setOptions wds
1101 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1105 setGHCiState st{ args = args }
1109 setGHCiState st{ progname = prog }
1111 io (hPutStrLn stderr "syntax: :set prog <progname>")
1115 setGHCiState st{ editor = cmd }
1117 setStop str@(c:_) | isDigit c
1118 = do let (nm_str,rest) = break (not.isDigit) str
1121 let old_breaks = breaks st
1122 if all ((/= nm) . fst) old_breaks
1123 then printForUser (text "Breakpoint" <+> ppr nm <+>
1124 text "does not exist")
1126 let new_breaks = map fn old_breaks
1127 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1128 | otherwise = (i,loc)
1129 setGHCiState st{ breaks = new_breaks }
1132 setGHCiState st{ stop = cmd }
1134 setPrompt value = do
1137 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1138 else setGHCiState st{ prompt = remQuotes value }
1140 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1144 do -- first, deal with the GHCi opts (+s, +t, etc.)
1145 let (plus_opts, minus_opts) = partition isPlus wds
1146 mapM_ setOpt plus_opts
1147 -- then, dynamic flags
1148 newDynFlags minus_opts
1150 newDynFlags minus_opts = do
1151 dflags <- getDynFlags
1152 let pkg_flags = packageFlags dflags
1153 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1155 if (not (null leftovers))
1156 then throwDyn (CmdLineError ("unrecognised flags: " ++
1160 new_pkgs <- setDynFlags dflags'
1162 -- if the package flags changed, we should reset the context
1163 -- and link the new packages.
1164 dflags <- getDynFlags
1165 when (packageFlags dflags /= pkg_flags) $ do
1166 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1167 session <- getSession
1168 io (GHC.setTargets session [])
1169 io (GHC.load session LoadAllTargets)
1170 io (linkPackages dflags new_pkgs)
1171 setContextAfterLoad session []
1175 unsetOptions :: String -> GHCi ()
1177 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1178 let opts = words str
1179 (minus_opts, rest1) = partition isMinus opts
1180 (plus_opts, rest2) = partition isPlus rest1
1182 if (not (null rest2))
1183 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1186 mapM_ unsetOpt plus_opts
1188 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1189 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1191 no_flags <- mapM no_flag minus_opts
1192 newDynFlags no_flags
1194 isMinus ('-':s) = True
1197 isPlus ('+':s) = True
1201 = case strToGHCiOpt str of
1202 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1203 Just o -> setOption o
1206 = case strToGHCiOpt str of
1207 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1208 Just o -> unsetOption o
1210 strToGHCiOpt :: String -> (Maybe GHCiOption)
1211 strToGHCiOpt "s" = Just ShowTiming
1212 strToGHCiOpt "t" = Just ShowType
1213 strToGHCiOpt "r" = Just RevertCAFs
1214 strToGHCiOpt _ = Nothing
1216 optToStr :: GHCiOption -> String
1217 optToStr ShowTiming = "s"
1218 optToStr ShowType = "t"
1219 optToStr RevertCAFs = "r"
1221 -- ---------------------------------------------------------------------------
1227 ["args"] -> io $ putStrLn (show (args st))
1228 ["prog"] -> io $ putStrLn (show (progname st))
1229 ["prompt"] -> io $ putStrLn (show (prompt st))
1230 ["editor"] -> io $ putStrLn (show (editor st))
1231 ["stop"] -> io $ putStrLn (show (stop st))
1232 ["modules" ] -> showModules
1233 ["bindings"] -> showBindings
1234 ["linker"] -> io showLinkerState
1235 ["breaks"] -> showBkptTable
1236 ["context"] -> showContext
1237 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1240 session <- getSession
1241 let show_one ms = do m <- io (GHC.showModule session ms)
1243 graph <- io (GHC.getModuleGraph session)
1244 mapM_ show_one graph
1248 unqual <- io (GHC.getPrintUnqual s)
1249 bindings <- io (GHC.getBindings s)
1250 mapM_ showTyThing bindings
1253 showTyThing (AnId id) = do
1254 ty' <- cleanType (GHC.idType id)
1255 printForUser $ ppr id <> text " :: " <> ppr ty'
1256 showTyThing _ = return ()
1258 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1259 cleanType :: Type -> GHCi Type
1261 dflags <- getDynFlags
1262 if dopt Opt_GlasgowExts dflags
1264 else return $! GHC.dropForAlls ty
1266 showBkptTable :: GHCi ()
1269 printForUser $ prettyLocations (breaks st)
1271 showContext :: GHCi ()
1273 session <- getSession
1274 resumes <- io $ GHC.getResumeContext session
1275 printForUser $ vcat (map pp_resume (reverse resumes))
1278 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1279 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1282 -- -----------------------------------------------------------------------------
1285 completeNone :: String -> IO [String]
1286 completeNone w = return []
1289 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1290 completeWord w start end = do
1291 line <- Readline.getLineBuffer
1293 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1295 | Just c <- is_cmd line -> do
1296 maybe_cmd <- lookupCommand c
1297 let (n,w') = selectWord (words' 0 line)
1299 Nothing -> return Nothing
1300 Just (_,_,False,complete) -> wrapCompleter complete w
1301 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1302 return (map (drop n) rets)
1303 in wrapCompleter complete' w'
1305 --printf "complete %s, start = %d, end = %d\n" w start end
1306 wrapCompleter completeIdentifier w
1307 where words' _ [] = []
1308 words' n str = let (w,r) = break isSpace str
1309 (s,r') = span isSpace r
1310 in (n,w):words' (n+length w+length s) r'
1311 -- In a Haskell expression we want to parse 'a-b' as three words
1312 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1313 -- only be a single word.
1314 selectWord [] = (0,w)
1315 selectWord ((offset,x):xs)
1316 | offset+length x >= start = (start-offset,take (end-offset) x)
1317 | otherwise = selectWord xs
1320 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1321 | otherwise = Nothing
1324 cmds <- readIORef commands
1325 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1327 completeMacro w = do
1328 cmds <- readIORef commands
1329 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1330 return (filter (w `isPrefixOf`) cmds')
1332 completeIdentifier w = do
1334 rdrs <- GHC.getRdrNamesInScope s
1335 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1337 completeModule w = do
1339 dflags <- GHC.getSessionDynFlags s
1340 let pkg_mods = allExposedModules dflags
1341 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1343 completeHomeModule w = do
1345 g <- GHC.getModuleGraph s
1346 let home_mods = map GHC.ms_mod_name g
1347 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1349 completeSetOptions w = do
1350 return (filter (w `isPrefixOf`) options)
1351 where options = "args":"prog":allFlags
1353 completeFilename = Readline.filenameCompletionFunction
1355 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1357 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1358 unionComplete f1 f2 w = do
1363 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1364 wrapCompleter fun w = do
1367 [] -> return Nothing
1368 [x] -> return (Just (x,[]))
1369 xs -> case getCommonPrefix xs of
1370 "" -> return (Just ("",xs))
1371 pref -> return (Just (pref,xs))
1373 getCommonPrefix :: [String] -> String
1374 getCommonPrefix [] = ""
1375 getCommonPrefix (s:ss) = foldl common s ss
1376 where common s "" = ""
1378 common (c:cs) (d:ds)
1379 | c == d = c : common cs ds
1382 allExposedModules :: DynFlags -> [ModuleName]
1383 allExposedModules dflags
1384 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1386 pkg_db = pkgIdMap (pkgState dflags)
1388 completeCmd = completeNone
1389 completeMacro = completeNone
1390 completeIdentifier = completeNone
1391 completeModule = completeNone
1392 completeHomeModule = completeNone
1393 completeSetOptions = completeNone
1394 completeFilename = completeNone
1395 completeHomeModuleOrFile=completeNone
1396 completeBkpt = completeNone
1399 -- ---------------------------------------------------------------------------
1400 -- User code exception handling
1402 -- This is the exception handler for exceptions generated by the
1403 -- user's code and exceptions coming from children sessions;
1404 -- it normally just prints out the exception. The
1405 -- handler must be recursive, in case showing the exception causes
1406 -- more exceptions to be raised.
1408 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1409 -- raising another exception. We therefore don't put the recursive
1410 -- handler arond the flushing operation, so if stderr is closed
1411 -- GHCi will just die gracefully rather than going into an infinite loop.
1412 handler :: Exception -> GHCi Bool
1414 handler exception = do
1416 io installSignalHandlers
1417 ghciHandle handler (showException exception >> return False)
1419 showException (DynException dyn) =
1420 case fromDynamic dyn of
1421 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1422 Just Interrupted -> io (putStrLn "Interrupted.")
1423 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1424 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1425 Just other_ghc_ex -> io (print other_ghc_ex)
1427 showException other_exception
1428 = io (putStrLn ("*** Exception: " ++ show other_exception))
1430 -----------------------------------------------------------------------------
1431 -- recursive exception handlers
1433 -- Don't forget to unblock async exceptions in the handler, or if we're
1434 -- in an exception loop (eg. let a = error a in a) the ^C exception
1435 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1437 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1438 ghciHandle h (GHCi m) = GHCi $ \s ->
1439 Exception.catch (m s)
1440 (\e -> unGHCi (ghciUnblock (h e)) s)
1442 ghciUnblock :: GHCi a -> GHCi a
1443 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1446 -- ----------------------------------------------------------------------------
1449 expandPath :: String -> GHCi String
1451 case dropWhile isSpace path of
1453 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1454 return (tilde ++ '/':d)
1458 wantInterpretedModule :: String -> GHCi Module
1459 wantInterpretedModule str = do
1460 session <- getSession
1461 modl <- lookupModule str
1462 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1463 when (not is_interpreted) $
1464 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1467 wantNameFromInterpretedModule noCanDo str and_then = do
1468 session <- getSession
1469 names <- io $ GHC.parseName session str
1473 let modl = GHC.nameModule n
1474 if not (GHC.isExternalName n)
1475 then noCanDo n $ ppr n <>
1476 text " is not defined in an interpreted module"
1478 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1479 if not is_interpreted
1480 then noCanDo n $ text "module " <> ppr modl <>
1481 text " is not interpreted"
1484 -- ----------------------------------------------------------------------------
1485 -- Windows console setup
1487 setUpConsole :: IO ()
1489 #ifdef mingw32_HOST_OS
1490 -- On Windows we need to set a known code page, otherwise the characters
1491 -- we read from the console will be be in some strange encoding, and
1492 -- similarly for characters we write to the console.
1494 -- At the moment, GHCi pretends all input is Latin-1. In the
1495 -- future we should support UTF-8, but for now we set the code pages
1498 -- It seems you have to set the font in the console window to
1499 -- a Unicode font in order for output to work properly,
1500 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1501 -- (see MSDN for SetConsoleOutputCP()).
1503 setConsoleCP 28591 -- ISO Latin-1
1504 setConsoleOutputCP 28591 -- ISO Latin-1
1508 -- -----------------------------------------------------------------------------
1509 -- commands for debugger
1511 sprintCmd = pprintCommand False False
1512 printCmd = pprintCommand True False
1513 forceCmd = pprintCommand False True
1515 pprintCommand bind force str = do
1516 session <- getSession
1517 io $ pprintClosureCommand session bind force str
1519 stepCmd :: String -> GHCi ()
1520 stepCmd [] = doContinue GHC.SingleStep
1521 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1523 traceCmd :: String -> GHCi ()
1524 traceCmd [] = doContinue GHC.RunAndLogSteps
1525 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1527 continueCmd :: String -> GHCi ()
1528 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1530 doContinue :: SingleStep -> GHCi ()
1531 doContinue step = do
1532 session <- getSession
1533 runResult <- io $ GHC.resume session step
1534 afterRunStmt runResult
1537 abandonCmd :: String -> GHCi ()
1538 abandonCmd = noArgs $ do
1540 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1541 when (not b) $ io $ putStrLn "There is no computation running."
1544 deleteCmd :: String -> GHCi ()
1545 deleteCmd argLine = do
1546 deleteSwitch $ words argLine
1548 deleteSwitch :: [String] -> GHCi ()
1550 io $ putStrLn "The delete command requires at least one argument."
1551 -- delete all break points
1552 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1553 deleteSwitch idents = do
1554 mapM_ deleteOneBreak idents
1556 deleteOneBreak :: String -> GHCi ()
1558 | all isDigit str = deleteBreak (read str)
1559 | otherwise = return ()
1561 historyCmd :: String -> GHCi ()
1563 | null arg = history 20
1564 | all isDigit arg = history (read arg)
1565 | otherwise = io $ putStrLn "Syntax: :history [num]"
1569 resumes <- io $ GHC.getResumeContext s
1571 [] -> io $ putStrLn "Not stopped at a breakpoint"
1573 let hist = GHC.resumeHistory r
1574 (took,rest) = splitAt num hist
1575 spans <- mapM (io . GHC.getHistorySpan s) took
1576 let nums = map (printf "-%-3d:") [(1::Int)..]
1577 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1578 io $ putStrLn $ if null rest then "<end of history>" else "..."
1580 backCmd :: String -> GHCi ()
1581 backCmd = noArgs $ do
1583 (names, ix, span) <- io $ GHC.back s
1584 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1585 mapM_ (showTypeOfName s) names
1586 -- run the command set with ":set stop <cmd>"
1588 enqueueCommands [stop st]
1590 forwardCmd :: String -> GHCi ()
1591 forwardCmd = noArgs $ do
1593 (names, ix, span) <- io $ GHC.forward s
1594 printForUser $ (if (ix == 0)
1595 then ptext SLIT("Stopped at")
1596 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1597 mapM_ (showTypeOfName s) names
1598 -- run the command set with ":set stop <cmd>"
1600 enqueueCommands [stop st]
1602 -- handle the "break" command
1603 breakCmd :: String -> GHCi ()
1604 breakCmd argLine = do
1605 session <- getSession
1606 breakSwitch session $ words argLine
1608 breakSwitch :: Session -> [String] -> GHCi ()
1609 breakSwitch _session [] = do
1610 io $ putStrLn "The break command requires at least one argument."
1611 breakSwitch session args@(arg1:rest)
1612 | looksLikeModuleName arg1 = do
1613 mod <- wantInterpretedModule arg1
1614 breakByModule session mod rest
1615 | all isDigit arg1 = do
1616 (toplevel, _) <- io $ GHC.getContext session
1618 (mod : _) -> breakByModuleLine mod (read arg1) rest
1620 io $ putStrLn "Cannot find default module for breakpoint."
1621 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1622 | otherwise = do -- try parsing it as an identifier
1623 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1624 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1625 if GHC.isGoodSrcLoc loc
1626 then findBreakAndSet (GHC.nameModule name) $
1627 findBreakByCoord (Just (GHC.srcLocFile loc))
1628 (GHC.srcLocLine loc,
1630 else noCanDo name $ text "can't find its location: " <> ppr loc
1632 noCanDo n why = printForUser $
1633 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1635 breakByModule :: Session -> Module -> [String] -> GHCi ()
1636 breakByModule session mod args@(arg1:rest)
1637 | all isDigit arg1 = do -- looks like a line number
1638 breakByModuleLine mod (read arg1) rest
1639 | otherwise = io $ putStrLn "Invalid arguments to :break"
1641 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1642 breakByModuleLine mod line args
1643 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1644 | [col] <- args, all isDigit col =
1645 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1646 | otherwise = io $ putStrLn "Invalid arguments to :break"
1648 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1649 findBreakAndSet mod lookupTickTree = do
1650 tickArray <- getTickArray mod
1651 (breakArray, _) <- getModBreak mod
1652 case lookupTickTree tickArray of
1653 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1654 Just (tick, span) -> do
1655 success <- io $ setBreakFlag True breakArray tick
1656 session <- getSession
1660 recordBreak $ BreakLocation
1667 text "Breakpoint " <> ppr nm <>
1669 then text " was already set at " <> ppr span
1670 else text " activated at " <> ppr span
1672 printForUser $ text "Breakpoint could not be activated at"
1675 -- When a line number is specified, the current policy for choosing
1676 -- the best breakpoint is this:
1677 -- - the leftmost complete subexpression on the specified line, or
1678 -- - the leftmost subexpression starting on the specified line, or
1679 -- - the rightmost subexpression enclosing the specified line
1681 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1682 findBreakByLine line arr
1683 | not (inRange (bounds arr) line) = Nothing
1685 listToMaybe (sortBy leftmost_largest complete) `mplus`
1686 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1687 listToMaybe (sortBy rightmost ticks)
1691 starts_here = [ tick | tick@(nm,span) <- ticks,
1692 GHC.srcSpanStartLine span == line ]
1694 (complete,incomplete) = partition ends_here starts_here
1695 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1697 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1698 -> Maybe (BreakIndex,SrcSpan)
1699 findBreakByCoord mb_file (line, col) arr
1700 | not (inRange (bounds arr) line) = Nothing
1702 listToMaybe (sortBy rightmost contains) `mplus`
1703 listToMaybe (sortBy leftmost_smallest after_here)
1707 -- the ticks that span this coordinate
1708 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1709 is_correct_file span ]
1711 is_correct_file span
1712 | Just f <- mb_file = GHC.srcSpanFile span == f
1715 after_here = [ tick | tick@(nm,span) <- ticks,
1716 GHC.srcSpanStartLine span == line,
1717 GHC.srcSpanStartCol span >= col ]
1720 leftmost_smallest (_,a) (_,b) = a `compare` b
1721 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1723 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1724 rightmost (_,a) (_,b) = b `compare` a
1726 spans :: SrcSpan -> (Int,Int) -> Bool
1727 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1728 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1730 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1731 -- of carets under the active expression instead. The Windows console
1732 -- doesn't support ANSI escape sequences, and most Unix terminals
1733 -- (including xterm) do, so this is a reasonable guess until we have a
1734 -- proper termcap/terminfo library.
1735 #if !defined(mingw32_TARGET_OS)
1741 start_bold = BS.pack "\ESC[1m"
1742 end_bold = BS.pack "\ESC[0m"
1744 listCmd :: String -> GHCi ()
1746 mb_span <- getCurrentBreakSpan
1748 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1749 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1750 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1751 listCmd str = list2 (words str)
1753 list2 [arg] | all isDigit arg = do
1754 session <- getSession
1755 (toplevel, _) <- io $ GHC.getContext session
1757 [] -> io $ putStrLn "No module to list"
1758 (mod : _) -> listModuleLine mod (read arg)
1759 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1760 mod <- wantInterpretedModule arg1
1761 listModuleLine mod (read arg2)
1763 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1764 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1765 if GHC.isGoodSrcLoc loc
1767 tickArray <- getTickArray (GHC.nameModule name)
1768 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1769 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1772 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1773 Just (_,span) -> io $ listAround span False
1775 noCanDo name $ text "can't find its location: " <>
1778 noCanDo n why = printForUser $
1779 text "cannot list source code for " <> ppr n <> text ": " <> why
1781 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1783 listModuleLine :: Module -> Int -> GHCi ()
1784 listModuleLine modl line = do
1785 session <- getSession
1786 graph <- io (GHC.getModuleGraph session)
1787 let this = filter ((== modl) . GHC.ms_mod) graph
1789 [] -> panic "listModuleLine"
1791 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1792 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1793 io $ listAround (GHC.srcLocSpan loc) False
1795 -- | list a section of a source file around a particular SrcSpan.
1796 -- If the highlight flag is True, also highlight the span using
1797 -- start_bold/end_bold.
1798 listAround span do_highlight = do
1800 contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1802 lines = BS.split '\n' contents
1803 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1804 drop (line1 - 1 - pad_before) $ lines
1805 fst_line = max 1 (line1 - pad_before)
1806 line_nos = [ fst_line .. ]
1808 highlighted | do_highlight = zipWith highlight line_nos these_lines
1809 | otherwise = these_lines
1811 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1812 prefixed = zipWith BS.append bs_line_nos highlighted
1814 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1816 file = GHC.srcSpanFile span
1817 line1 = GHC.srcSpanStartLine span
1818 col1 = GHC.srcSpanStartCol span
1819 line2 = GHC.srcSpanEndLine span
1820 col2 = GHC.srcSpanEndCol span
1822 pad_before | line1 == 1 = 0
1826 highlight | do_bold = highlight_bold
1827 | otherwise = highlight_carets
1829 highlight_bold no line
1830 | no == line1 && no == line2
1831 = let (a,r) = BS.splitAt col1 line
1832 (b,c) = BS.splitAt (col2-col1) r
1834 BS.concat [a,start_bold,b,end_bold,c]
1836 = let (a,b) = BS.splitAt col1 line in
1837 BS.concat [a, start_bold, b]
1839 = let (a,b) = BS.splitAt col2 line in
1840 BS.concat [a, end_bold, b]
1843 highlight_carets no line
1844 | no == line1 && no == line2
1845 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1846 BS.replicate (col2-col1) '^']
1848 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1849 BS.replicate (BS.length line-col1) '^']
1851 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1854 indent = BS.pack " "
1855 nl = BS.singleton '\n'
1857 -- --------------------------------------------------------------------------
1860 getTickArray :: Module -> GHCi TickArray
1861 getTickArray modl = do
1863 let arrmap = tickarrays st
1864 case lookupModuleEnv arrmap modl of
1865 Just arr -> return arr
1867 (breakArray, ticks) <- getModBreak modl
1868 let arr = mkTickArray (assocs ticks)
1869 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1872 discardTickArrays :: GHCi ()
1873 discardTickArrays = do
1875 setGHCiState st{tickarrays = emptyModuleEnv}
1877 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1879 = accumArray (flip (:)) [] (1, max_line)
1880 [ (line, (nm,span)) | (nm,span) <- ticks,
1881 line <- srcSpanLines span ]
1883 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1884 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1885 GHC.srcSpanEndLine span ]
1887 lookupModule :: String -> GHCi Module
1888 lookupModule modName
1889 = do session <- getSession
1890 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1892 -- don't reset the counter back to zero?
1893 discardActiveBreakPoints :: GHCi ()
1894 discardActiveBreakPoints = do
1896 mapM (turnOffBreak.snd) (breaks st)
1897 setGHCiState $ st { breaks = [] }
1899 deleteBreak :: Int -> GHCi ()
1900 deleteBreak identity = do
1902 let oldLocations = breaks st
1903 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1905 then printForUser (text "Breakpoint" <+> ppr identity <+>
1906 text "does not exist")
1908 mapM (turnOffBreak.snd) this
1909 setGHCiState $ st { breaks = rest }
1911 turnOffBreak loc = do
1912 (arr, _) <- getModBreak (breakModule loc)
1913 io $ setBreakFlag False arr (breakTick loc)
1915 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1916 getModBreak mod = do
1917 session <- getSession
1918 Just mod_info <- io $ GHC.getModuleInfo session mod
1919 let modBreaks = GHC.modInfoModBreaks mod_info
1920 let array = GHC.modBreaks_flags modBreaks
1921 let ticks = GHC.modBreaks_locs modBreaks
1922 return (array, ticks)
1924 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1925 setBreakFlag toggle array index
1926 | toggle = GHC.setBreakOn array index
1927 | otherwise = GHC.setBreakOff array index