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"++
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 " :step single-step after stopping at a breakpoint\n"++
190 " :step <expr> single-step into <expr>\n"++
191 " :trace trace after stopping at a breakpoint\n"++
192 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
193 " :sprint [<name> ...] simplifed version of :print\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
559 = do st <- getGHCiState
560 session <- getSession
561 result <- io $ withProgName (progname st) $ withArgs (args st) $
562 GHC.runStmt session stmt step
566 afterRunStmt :: GHC.RunResult -> GHCi Bool
567 -- False <=> the statement failed to compile
568 afterRunStmt (GHC.RunException e) = throw e
569 afterRunStmt run_result = do
570 session <- getSession
572 GHC.RunOk names -> do
573 show_types <- isOptionSet ShowType
574 when show_types $ mapM_ (showTypeOfName session) names
575 GHC.RunBreak _ names mb_info -> do
576 resumes <- io $ GHC.getResumeContext session
577 printForUser $ ptext SLIT("Stopped at") <+>
578 ppr (GHC.resumeSpan (head resumes))
579 mapM_ (showTypeOfName session) names
580 maybe (return ()) runBreakCmd mb_info
581 -- run the command set with ":set stop <cmd>"
583 enqueueCommands [stop st]
588 io installSignalHandlers
589 b <- isOptionSet RevertCAFs
590 io (when b revertCAFs)
592 return (case run_result of GHC.RunOk _ -> True; _ -> False)
594 runBreakCmd :: GHC.BreakInfo -> GHCi ()
595 runBreakCmd info = do
596 let mod = GHC.breakInfo_module info
597 nm = GHC.breakInfo_number info
599 case [ loc | (i,loc) <- breaks st,
600 breakModule loc == mod, breakTick loc == nm ] of
602 loc:_ | null cmd -> return ()
603 | otherwise -> do enqueueCommands [cmd]; return ()
604 where cmd = onBreakCmd loc
606 showTypeOfName :: Session -> Name -> GHCi ()
607 showTypeOfName session n
608 = do maybe_tything <- io (GHC.lookupName session n)
609 case maybe_tything of
611 Just thing -> showTyThing thing
613 specialCommand :: String -> GHCi Bool
614 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
615 specialCommand str = do
616 let (cmd,rest) = break isSpace str
617 maybe_cmd <- io (lookupCommand cmd)
619 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
620 ++ shortHelpText) >> return False)
621 Just (_,f,_,_) -> f (dropWhile isSpace rest)
623 lookupCommand :: String -> IO (Maybe Command)
624 lookupCommand str = do
625 cmds <- readIORef commands
626 -- look for exact match first, then the first prefix match
627 case [ c | c <- cmds, str == cmdName c ] of
628 c:_ -> return (Just c)
629 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
631 c:_ -> return (Just c)
634 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
635 getCurrentBreakSpan = do
636 session <- getSession
637 resumes <- io $ GHC.getResumeContext session
641 let ix = GHC.resumeHistoryIx r
643 then return (Just (GHC.resumeSpan r))
645 let hist = GHC.resumeHistory r !! (ix-1)
646 span <- io $ GHC.getHistorySpan session hist
649 -----------------------------------------------------------------------------
652 noArgs :: GHCi () -> String -> GHCi ()
654 noArgs m _ = io $ putStrLn "This command takes no arguments"
656 help :: String -> GHCi ()
657 help _ = io (putStr helpText)
659 info :: String -> GHCi ()
660 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
661 info s = do { let names = words s
662 ; session <- getSession
663 ; dflags <- getDynFlags
664 ; let exts = dopt Opt_GlasgowExts dflags
665 ; mapM_ (infoThing exts session) names }
667 infoThing exts session str = io $ do
668 names <- GHC.parseName session str
669 let filtered = filterOutChildren names
670 mb_stuffs <- mapM (GHC.getInfo session) filtered
671 unqual <- GHC.getPrintUnqual session
672 putStrLn (showSDocForUser unqual $
673 vcat (intersperse (text "") $
674 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
676 -- Filter out names whose parent is also there Good
677 -- example is '[]', which is both a type and data
678 -- constructor in the same type
679 filterOutChildren :: [Name] -> [Name]
680 filterOutChildren names = filter (not . parent_is_there) names
681 where parent_is_there n
682 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
686 pprInfo exts (thing, fixity, insts)
687 = pprTyThingInContextLoc exts thing
688 $$ show_fixity fixity
689 $$ vcat (map GHC.pprInstance insts)
692 | fix == GHC.defaultFixity = empty
693 | otherwise = ppr fix <+> ppr (GHC.getName thing)
695 runMain :: String -> GHCi ()
697 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
698 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
700 addModule :: [FilePath] -> GHCi ()
702 io (revertCAFs) -- always revert CAFs on load/add.
703 files <- mapM expandPath files
704 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
705 session <- getSession
706 io (mapM_ (GHC.addTarget session) targets)
707 ok <- io (GHC.load session LoadAllTargets)
710 changeDirectory :: String -> GHCi ()
711 changeDirectory dir = do
712 session <- getSession
713 graph <- io (GHC.getModuleGraph session)
714 when (not (null graph)) $
715 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
716 io (GHC.setTargets session [])
717 io (GHC.load session LoadAllTargets)
718 setContextAfterLoad session []
719 io (GHC.workingDirectoryChanged session)
720 dir <- expandPath dir
721 io (setCurrentDirectory dir)
723 editFile :: String -> GHCi ()
726 -- find the name of the "topmost" file loaded
727 session <- getSession
728 graph0 <- io (GHC.getModuleGraph session)
729 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
730 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
731 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
732 Just file -> do_edit file
733 Nothing -> throwDyn (CmdLineError "unknown file name")
734 | otherwise = do_edit str
740 throwDyn (CmdLineError "editor not set, use :set editor")
741 io $ system (cmd ++ ' ':file)
744 defineMacro :: String -> GHCi ()
746 let (macro_name, definition) = break isSpace s
747 cmds <- io (readIORef commands)
749 then throwDyn (CmdLineError "invalid macro name")
751 if (macro_name `elem` map cmdName cmds)
752 then throwDyn (CmdLineError
753 ("command '" ++ macro_name ++ "' is already defined"))
756 -- give the expression a type signature, so we can be sure we're getting
757 -- something of the right type.
758 let new_expr = '(' : definition ++ ") :: String -> IO String"
760 -- compile the expression
762 maybe_hv <- io (GHC.compileExpr cms new_expr)
765 Just hv -> io (writeIORef commands --
766 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
768 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
770 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
771 enqueueCommands (lines str)
774 undefineMacro :: String -> GHCi ()
775 undefineMacro macro_name = do
776 cmds <- io (readIORef commands)
777 if (macro_name `elem` map cmdName builtin_commands)
778 then throwDyn (CmdLineError
779 ("command '" ++ macro_name ++ "' cannot be undefined"))
781 if (macro_name `notElem` map cmdName cmds)
782 then throwDyn (CmdLineError
783 ("command '" ++ macro_name ++ "' not defined"))
785 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
787 cmdCmd :: String -> GHCi ()
789 let expr = '(' : str ++ ") :: IO String"
790 session <- getSession
791 maybe_hv <- io (GHC.compileExpr session expr)
795 cmds <- io $ (unsafeCoerce# hv :: IO String)
796 enqueueCommands (lines cmds)
799 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
800 loadModule fs = timeIt (loadModule' fs)
802 loadModule_ :: [FilePath] -> GHCi ()
803 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
805 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
806 loadModule' files = do
807 session <- getSession
810 discardActiveBreakPoints
811 io (GHC.setTargets session [])
812 io (GHC.load session LoadAllTargets)
815 let (filenames, phases) = unzip files
816 exp_filenames <- mapM expandPath filenames
817 let files' = zip exp_filenames phases
818 targets <- io (mapM (uncurry GHC.guessTarget) files')
820 -- NOTE: we used to do the dependency anal first, so that if it
821 -- fails we didn't throw away the current set of modules. This would
822 -- require some re-working of the GHC interface, so we'll leave it
823 -- as a ToDo for now.
825 io (GHC.setTargets session targets)
826 doLoad session LoadAllTargets
828 checkModule :: String -> GHCi ()
830 let modl = GHC.mkModuleName m
831 session <- getSession
832 result <- io (GHC.checkModule session modl)
834 Nothing -> io $ putStrLn "Nothing"
835 Just r -> io $ putStrLn (showSDoc (
836 case GHC.checkedModuleInfo r of
837 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
839 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
841 (text "global names: " <+> ppr global) $$
842 (text "local names: " <+> ppr local)
844 afterLoad (successIf (isJust result)) session
846 reloadModule :: String -> GHCi ()
848 io (revertCAFs) -- always revert CAFs on reload.
849 discardActiveBreakPoints
850 session <- getSession
851 doLoad session LoadAllTargets
854 io (revertCAFs) -- always revert CAFs on reload.
855 discardActiveBreakPoints
856 session <- getSession
857 doLoad session (LoadUpTo (GHC.mkModuleName m))
860 doLoad session howmuch = do
861 -- turn off breakpoints before we load: we can't turn them off later, because
862 -- the ModBreaks will have gone away.
863 discardActiveBreakPoints
864 ok <- io (GHC.load session howmuch)
868 afterLoad ok session = do
869 io (revertCAFs) -- always revert CAFs on load.
871 graph <- io (GHC.getModuleGraph session)
872 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
873 setContextAfterLoad session graph'
874 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
876 setContextAfterLoad session [] = do
877 prel_mod <- getPrelude
878 io (GHC.setContext session [] [prel_mod])
879 setContextAfterLoad session ms = do
880 -- load a target if one is available, otherwise load the topmost module.
881 targets <- io (GHC.getTargets session)
882 case [ m | Just m <- map (findTarget ms) targets ] of
884 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
885 load_this (last graph')
890 = case filter (`matches` t) ms of
894 summary `matches` Target (TargetModule m) _
895 = GHC.ms_mod_name summary == m
896 summary `matches` Target (TargetFile f _) _
897 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
898 summary `matches` target
901 load_this summary | m <- GHC.ms_mod summary = do
902 b <- io (GHC.moduleIsInterpreted session m)
903 if b then io (GHC.setContext session [m] [])
905 prel_mod <- getPrelude
906 io (GHC.setContext session [] [prel_mod,m])
909 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
910 modulesLoadedMsg ok mods = do
911 dflags <- getDynFlags
912 when (verbosity dflags > 0) $ do
914 | null mods = text "none."
916 punctuate comma (map ppr mods)) <> text "."
919 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
921 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
924 typeOfExpr :: String -> GHCi ()
926 = do cms <- getSession
927 maybe_ty <- io (GHC.exprType cms str)
930 Just ty -> do ty' <- cleanType ty
931 printForUser $ text str <> text " :: " <> ppr ty'
933 kindOfType :: String -> GHCi ()
935 = do cms <- getSession
936 maybe_ty <- io (GHC.typeKind cms str)
939 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
941 quit :: String -> GHCi Bool
944 shellEscape :: String -> GHCi Bool
945 shellEscape str = io (system str >> return False)
947 -----------------------------------------------------------------------------
948 -- Browsing a module's contents
950 browseCmd :: String -> GHCi ()
953 ['*':m] | looksLikeModuleName m -> browseModule m False
954 [m] | looksLikeModuleName m -> browseModule m True
955 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
957 browseModule m exports_only = do
959 modl <- if exports_only then lookupModule m
960 else wantInterpretedModule m
962 -- Temporarily set the context to the module we're interested in,
963 -- just so we can get an appropriate PrintUnqualified
964 (as,bs) <- io (GHC.getContext s)
965 prel_mod <- getPrelude
966 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
967 else GHC.setContext s [modl] [])
968 unqual <- io (GHC.getPrintUnqual s)
969 io (GHC.setContext s as bs)
971 mb_mod_info <- io $ GHC.getModuleInfo s modl
973 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
976 | exports_only = GHC.modInfoExports mod_info
977 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
979 filtered = filterOutChildren names
981 things <- io $ mapM (GHC.lookupName s) filtered
983 dflags <- getDynFlags
984 let exts = dopt Opt_GlasgowExts dflags
985 io (putStrLn (showSDocForUser unqual (
986 vcat (map (pprTyThingInContext exts) (catMaybes things))
988 -- ToDo: modInfoInstances currently throws an exception for
989 -- package modules. When it works, we can do this:
990 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
992 -----------------------------------------------------------------------------
993 -- Setting the module context
996 | all sensible mods = fn mods
997 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
999 (fn, mods) = case str of
1000 '+':stuff -> (addToContext, words stuff)
1001 '-':stuff -> (removeFromContext, words stuff)
1002 stuff -> (newContext, words stuff)
1004 sensible ('*':m) = looksLikeModuleName m
1005 sensible m = looksLikeModuleName m
1007 separate :: Session -> [String] -> [Module] -> [Module]
1008 -> GHCi ([Module],[Module])
1009 separate session [] as bs = return (as,bs)
1010 separate session (('*':str):ms) as bs = do
1011 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1012 b <- io $ GHC.moduleIsInterpreted session m
1013 if b then separate session ms (m:as) bs
1014 else throwDyn (CmdLineError ("module '"
1015 ++ GHC.moduleNameString (GHC.moduleName m)
1016 ++ "' is not interpreted"))
1017 separate session (str:ms) as bs = do
1018 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1019 separate session ms as (m:bs)
1021 newContext :: [String] -> GHCi ()
1022 newContext strs = do
1024 (as,bs) <- separate s strs [] []
1025 prel_mod <- getPrelude
1026 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1027 io $ GHC.setContext s as bs'
1030 addToContext :: [String] -> GHCi ()
1031 addToContext strs = do
1033 (as,bs) <- io $ GHC.getContext s
1035 (new_as,new_bs) <- separate s strs [] []
1037 let as_to_add = new_as \\ (as ++ bs)
1038 bs_to_add = new_bs \\ (as ++ bs)
1040 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1043 removeFromContext :: [String] -> GHCi ()
1044 removeFromContext strs = do
1046 (as,bs) <- io $ GHC.getContext s
1048 (as_to_remove,bs_to_remove) <- separate s strs [] []
1050 let as' = as \\ (as_to_remove ++ bs_to_remove)
1051 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1053 io $ GHC.setContext s as' bs'
1055 ----------------------------------------------------------------------------
1058 -- set options in the interpreter. Syntax is exactly the same as the
1059 -- ghc command line, except that certain options aren't available (-C,
1062 -- This is pretty fragile: most options won't work as expected. ToDo:
1063 -- figure out which ones & disallow them.
1065 setCmd :: String -> GHCi ()
1067 = do st <- getGHCiState
1068 let opts = options st
1069 io $ putStrLn (showSDoc (
1070 text "options currently set: " <>
1073 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1076 = case toArgs str of
1077 ("args":args) -> setArgs args
1078 ("prog":prog) -> setProg prog
1079 ("prompt":prompt) -> setPrompt (after 6)
1080 ("editor":cmd) -> setEditor (after 6)
1081 ("stop":cmd) -> setStop (after 4)
1082 wds -> setOptions wds
1083 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1087 setGHCiState st{ args = args }
1091 setGHCiState st{ progname = prog }
1093 io (hPutStrLn stderr "syntax: :set prog <progname>")
1097 setGHCiState st{ editor = cmd }
1099 setStop str@(c:_) | isDigit c
1100 = do let (nm_str,rest) = break (not.isDigit) str
1103 let old_breaks = breaks st
1104 if all ((/= nm) . fst) old_breaks
1105 then printForUser (text "Breakpoint" <+> ppr nm <+>
1106 text "does not exist")
1108 let new_breaks = map fn old_breaks
1109 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1110 | otherwise = (i,loc)
1111 setGHCiState st{ breaks = new_breaks }
1114 setGHCiState st{ stop = cmd }
1116 setPrompt value = do
1119 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1120 else setGHCiState st{ prompt = remQuotes value }
1122 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1126 do -- first, deal with the GHCi opts (+s, +t, etc.)
1127 let (plus_opts, minus_opts) = partition isPlus wds
1128 mapM_ setOpt plus_opts
1129 -- then, dynamic flags
1130 newDynFlags minus_opts
1132 newDynFlags minus_opts = do
1133 dflags <- getDynFlags
1134 let pkg_flags = packageFlags dflags
1135 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1137 if (not (null leftovers))
1138 then throwDyn (CmdLineError ("unrecognised flags: " ++
1142 new_pkgs <- setDynFlags dflags'
1144 -- if the package flags changed, we should reset the context
1145 -- and link the new packages.
1146 dflags <- getDynFlags
1147 when (packageFlags dflags /= pkg_flags) $ do
1148 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1149 session <- getSession
1150 io (GHC.setTargets session [])
1151 io (GHC.load session LoadAllTargets)
1152 io (linkPackages dflags new_pkgs)
1153 setContextAfterLoad session []
1157 unsetOptions :: String -> GHCi ()
1159 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1160 let opts = words str
1161 (minus_opts, rest1) = partition isMinus opts
1162 (plus_opts, rest2) = partition isPlus rest1
1164 if (not (null rest2))
1165 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1168 mapM_ unsetOpt plus_opts
1170 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1171 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1173 no_flags <- mapM no_flag minus_opts
1174 newDynFlags no_flags
1176 isMinus ('-':s) = True
1179 isPlus ('+':s) = True
1183 = case strToGHCiOpt str of
1184 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1185 Just o -> setOption o
1188 = case strToGHCiOpt str of
1189 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1190 Just o -> unsetOption o
1192 strToGHCiOpt :: String -> (Maybe GHCiOption)
1193 strToGHCiOpt "s" = Just ShowTiming
1194 strToGHCiOpt "t" = Just ShowType
1195 strToGHCiOpt "r" = Just RevertCAFs
1196 strToGHCiOpt _ = Nothing
1198 optToStr :: GHCiOption -> String
1199 optToStr ShowTiming = "s"
1200 optToStr ShowType = "t"
1201 optToStr RevertCAFs = "r"
1203 -- ---------------------------------------------------------------------------
1209 ["args"] -> io $ putStrLn (show (args st))
1210 ["prog"] -> io $ putStrLn (show (progname st))
1211 ["prompt"] -> io $ putStrLn (show (prompt st))
1212 ["editor"] -> io $ putStrLn (show (editor st))
1213 ["stop"] -> io $ putStrLn (show (stop st))
1214 ["modules" ] -> showModules
1215 ["bindings"] -> showBindings
1216 ["linker"] -> io showLinkerState
1217 ["breaks"] -> showBkptTable
1218 ["context"] -> showContext
1219 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1222 session <- getSession
1223 let show_one ms = do m <- io (GHC.showModule session ms)
1225 graph <- io (GHC.getModuleGraph session)
1226 mapM_ show_one graph
1230 unqual <- io (GHC.getPrintUnqual s)
1231 bindings <- io (GHC.getBindings s)
1232 mapM_ showTyThing bindings
1235 showTyThing (AnId id) = do
1236 ty' <- cleanType (GHC.idType id)
1237 printForUser $ ppr id <> text " :: " <> ppr ty'
1238 showTyThing _ = return ()
1240 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1241 cleanType :: Type -> GHCi Type
1243 dflags <- getDynFlags
1244 if dopt Opt_GlasgowExts dflags
1246 else return $! GHC.dropForAlls ty
1248 showBkptTable :: GHCi ()
1251 printForUser $ prettyLocations (breaks st)
1253 showContext :: GHCi ()
1255 session <- getSession
1256 resumes <- io $ GHC.getResumeContext session
1257 printForUser $ vcat (map pp_resume (reverse resumes))
1260 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1261 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1264 -- -----------------------------------------------------------------------------
1267 completeNone :: String -> IO [String]
1268 completeNone w = return []
1271 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1272 completeWord w start end = do
1273 line <- Readline.getLineBuffer
1275 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1277 | Just c <- is_cmd line -> do
1278 maybe_cmd <- lookupCommand c
1279 let (n,w') = selectWord (words' 0 line)
1281 Nothing -> return Nothing
1282 Just (_,_,False,complete) -> wrapCompleter complete w
1283 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1284 return (map (drop n) rets)
1285 in wrapCompleter complete' w'
1287 --printf "complete %s, start = %d, end = %d\n" w start end
1288 wrapCompleter completeIdentifier w
1289 where words' _ [] = []
1290 words' n str = let (w,r) = break isSpace str
1291 (s,r') = span isSpace r
1292 in (n,w):words' (n+length w+length s) r'
1293 -- In a Haskell expression we want to parse 'a-b' as three words
1294 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1295 -- only be a single word.
1296 selectWord [] = (0,w)
1297 selectWord ((offset,x):xs)
1298 | offset+length x >= start = (start-offset,take (end-offset) x)
1299 | otherwise = selectWord xs
1302 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1303 | otherwise = Nothing
1306 cmds <- readIORef commands
1307 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1309 completeMacro w = do
1310 cmds <- readIORef commands
1311 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1312 return (filter (w `isPrefixOf`) cmds')
1314 completeIdentifier w = do
1316 rdrs <- GHC.getRdrNamesInScope s
1317 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1319 completeModule w = do
1321 dflags <- GHC.getSessionDynFlags s
1322 let pkg_mods = allExposedModules dflags
1323 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1325 completeHomeModule w = do
1327 g <- GHC.getModuleGraph s
1328 let home_mods = map GHC.ms_mod_name g
1329 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1331 completeSetOptions w = do
1332 return (filter (w `isPrefixOf`) options)
1333 where options = "args":"prog":allFlags
1335 completeFilename = Readline.filenameCompletionFunction
1337 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1339 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1340 unionComplete f1 f2 w = do
1345 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1346 wrapCompleter fun w = do
1349 [] -> return Nothing
1350 [x] -> return (Just (x,[]))
1351 xs -> case getCommonPrefix xs of
1352 "" -> return (Just ("",xs))
1353 pref -> return (Just (pref,xs))
1355 getCommonPrefix :: [String] -> String
1356 getCommonPrefix [] = ""
1357 getCommonPrefix (s:ss) = foldl common s ss
1358 where common s "" = ""
1360 common (c:cs) (d:ds)
1361 | c == d = c : common cs ds
1364 allExposedModules :: DynFlags -> [ModuleName]
1365 allExposedModules dflags
1366 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1368 pkg_db = pkgIdMap (pkgState dflags)
1370 completeCmd = completeNone
1371 completeMacro = completeNone
1372 completeIdentifier = completeNone
1373 completeModule = completeNone
1374 completeHomeModule = completeNone
1375 completeSetOptions = completeNone
1376 completeFilename = completeNone
1377 completeHomeModuleOrFile=completeNone
1378 completeBkpt = completeNone
1381 -- ---------------------------------------------------------------------------
1382 -- User code exception handling
1384 -- This is the exception handler for exceptions generated by the
1385 -- user's code and exceptions coming from children sessions;
1386 -- it normally just prints out the exception. The
1387 -- handler must be recursive, in case showing the exception causes
1388 -- more exceptions to be raised.
1390 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1391 -- raising another exception. We therefore don't put the recursive
1392 -- handler arond the flushing operation, so if stderr is closed
1393 -- GHCi will just die gracefully rather than going into an infinite loop.
1394 handler :: Exception -> GHCi Bool
1396 handler exception = do
1398 io installSignalHandlers
1399 ghciHandle handler (showException exception >> return False)
1401 showException (DynException dyn) =
1402 case fromDynamic dyn of
1403 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1404 Just Interrupted -> io (putStrLn "Interrupted.")
1405 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1406 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1407 Just other_ghc_ex -> io (print other_ghc_ex)
1409 showException other_exception
1410 = io (putStrLn ("*** Exception: " ++ show other_exception))
1412 -----------------------------------------------------------------------------
1413 -- recursive exception handlers
1415 -- Don't forget to unblock async exceptions in the handler, or if we're
1416 -- in an exception loop (eg. let a = error a in a) the ^C exception
1417 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1419 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1420 ghciHandle h (GHCi m) = GHCi $ \s ->
1421 Exception.catch (m s)
1422 (\e -> unGHCi (ghciUnblock (h e)) s)
1424 ghciUnblock :: GHCi a -> GHCi a
1425 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1428 -- ----------------------------------------------------------------------------
1431 expandPath :: String -> GHCi String
1433 case dropWhile isSpace path of
1435 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1436 return (tilde ++ '/':d)
1440 wantInterpretedModule :: String -> GHCi Module
1441 wantInterpretedModule str = do
1442 session <- getSession
1443 modl <- lookupModule str
1444 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1445 when (not is_interpreted) $
1446 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1449 wantNameFromInterpretedModule noCanDo str and_then = do
1450 session <- getSession
1451 names <- io $ GHC.parseName session str
1455 let modl = GHC.nameModule n
1456 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1457 if not is_interpreted
1458 then noCanDo n $ text "module " <> ppr modl <>
1459 text " is not interpreted"
1462 -- ----------------------------------------------------------------------------
1463 -- Windows console setup
1465 setUpConsole :: IO ()
1467 #ifdef mingw32_HOST_OS
1468 -- On Windows we need to set a known code page, otherwise the characters
1469 -- we read from the console will be be in some strange encoding, and
1470 -- similarly for characters we write to the console.
1472 -- At the moment, GHCi pretends all input is Latin-1. In the
1473 -- future we should support UTF-8, but for now we set the code pages
1476 -- It seems you have to set the font in the console window to
1477 -- a Unicode font in order for output to work properly,
1478 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1479 -- (see MSDN for SetConsoleOutputCP()).
1481 setConsoleCP 28591 -- ISO Latin-1
1482 setConsoleOutputCP 28591 -- ISO Latin-1
1486 -- -----------------------------------------------------------------------------
1487 -- commands for debugger
1489 sprintCmd = pprintCommand False False
1490 printCmd = pprintCommand True False
1491 forceCmd = pprintCommand False True
1493 pprintCommand bind force str = do
1494 session <- getSession
1495 io $ pprintClosureCommand session bind force str
1497 stepCmd :: String -> GHCi ()
1498 stepCmd [] = doContinue GHC.SingleStep
1499 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1501 traceCmd :: String -> GHCi ()
1502 traceCmd [] = doContinue GHC.RunAndLogSteps
1503 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1505 continueCmd :: String -> GHCi ()
1506 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1508 doContinue :: SingleStep -> GHCi ()
1509 doContinue step = do
1510 session <- getSession
1511 runResult <- io $ GHC.resume session step
1512 afterRunStmt runResult
1515 abandonCmd :: String -> GHCi ()
1516 abandonCmd = noArgs $ do
1518 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1519 when (not b) $ io $ putStrLn "There is no computation running."
1522 deleteCmd :: String -> GHCi ()
1523 deleteCmd argLine = do
1524 deleteSwitch $ words argLine
1526 deleteSwitch :: [String] -> GHCi ()
1528 io $ putStrLn "The delete command requires at least one argument."
1529 -- delete all break points
1530 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1531 deleteSwitch idents = do
1532 mapM_ deleteOneBreak idents
1534 deleteOneBreak :: String -> GHCi ()
1536 | all isDigit str = deleteBreak (read str)
1537 | otherwise = return ()
1539 historyCmd :: String -> GHCi ()
1541 | null arg = history 20
1542 | all isDigit arg = history (read arg)
1543 | otherwise = io $ putStrLn "Syntax: :history [num]"
1547 resumes <- io $ GHC.getResumeContext s
1549 [] -> io $ putStrLn "Not stopped at a breakpoint"
1551 let hist = GHC.resumeHistory r
1552 (took,rest) = splitAt num hist
1553 spans <- mapM (io . GHC.getHistorySpan s) took
1554 let nums = map (printf "-%-3d:") [(1::Int)..]
1555 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1556 io $ putStrLn $ if null rest then "<end of history>" else "..."
1558 backCmd :: String -> GHCi ()
1559 backCmd = noArgs $ do
1561 (names, ix, span) <- io $ GHC.back s
1562 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1563 mapM_ (showTypeOfName s) names
1564 -- run the command set with ":set stop <cmd>"
1566 enqueueCommands [stop st]
1568 forwardCmd :: String -> GHCi ()
1569 forwardCmd = noArgs $ do
1571 (names, ix, span) <- io $ GHC.forward s
1572 printForUser $ (if (ix == 0)
1573 then ptext SLIT("Stopped at")
1574 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1575 mapM_ (showTypeOfName s) names
1576 -- run the command set with ":set stop <cmd>"
1578 enqueueCommands [stop st]
1580 -- handle the "break" command
1581 breakCmd :: String -> GHCi ()
1582 breakCmd argLine = do
1583 session <- getSession
1584 breakSwitch session $ words argLine
1586 breakSwitch :: Session -> [String] -> GHCi ()
1587 breakSwitch _session [] = do
1588 io $ putStrLn "The break command requires at least one argument."
1589 breakSwitch session args@(arg1:rest)
1590 | looksLikeModuleName arg1 = do
1591 mod <- wantInterpretedModule arg1
1592 breakByModule session mod rest
1593 | all isDigit arg1 = do
1594 (toplevel, _) <- io $ GHC.getContext session
1596 (mod : _) -> breakByModuleLine mod (read arg1) rest
1598 io $ putStrLn "Cannot find default module for breakpoint."
1599 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1600 | otherwise = do -- try parsing it as an identifier
1601 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1602 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1603 if GHC.isGoodSrcLoc loc
1604 then findBreakAndSet (GHC.nameModule name) $
1605 findBreakByCoord (Just (GHC.srcLocFile loc))
1606 (GHC.srcLocLine loc,
1608 else noCanDo name $ text "can't find its location: " <> ppr loc
1610 noCanDo n why = printForUser $
1611 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1613 breakByModule :: Session -> Module -> [String] -> GHCi ()
1614 breakByModule session mod args@(arg1:rest)
1615 | all isDigit arg1 = do -- looks like a line number
1616 breakByModuleLine mod (read arg1) rest
1617 | otherwise = io $ putStrLn "Invalid arguments to :break"
1619 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1620 breakByModuleLine mod line args
1621 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1622 | [col] <- args, all isDigit col =
1623 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1624 | otherwise = io $ putStrLn "Invalid arguments to :break"
1626 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1627 findBreakAndSet mod lookupTickTree = do
1628 tickArray <- getTickArray mod
1629 (breakArray, _) <- getModBreak mod
1630 case lookupTickTree tickArray of
1631 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1632 Just (tick, span) -> do
1633 success <- io $ setBreakFlag True breakArray tick
1634 session <- getSession
1638 recordBreak $ BreakLocation
1645 text "Breakpoint " <> ppr nm <>
1647 then text " was already set at " <> ppr span
1648 else text " activated at " <> ppr span
1650 printForUser $ text "Breakpoint could not be activated at"
1653 -- When a line number is specified, the current policy for choosing
1654 -- the best breakpoint is this:
1655 -- - the leftmost complete subexpression on the specified line, or
1656 -- - the leftmost subexpression starting on the specified line, or
1657 -- - the rightmost subexpression enclosing the specified line
1659 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1660 findBreakByLine line arr
1661 | not (inRange (bounds arr) line) = Nothing
1663 listToMaybe (sortBy leftmost_largest complete) `mplus`
1664 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1665 listToMaybe (sortBy rightmost ticks)
1669 starts_here = [ tick | tick@(nm,span) <- ticks,
1670 GHC.srcSpanStartLine span == line ]
1672 (complete,incomplete) = partition ends_here starts_here
1673 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1675 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1676 -> Maybe (BreakIndex,SrcSpan)
1677 findBreakByCoord mb_file (line, col) arr
1678 | not (inRange (bounds arr) line) = Nothing
1680 listToMaybe (sortBy rightmost contains)
1684 -- the ticks that span this coordinate
1685 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1686 is_correct_file span ]
1688 is_correct_file span
1689 | Just f <- mb_file = GHC.srcSpanFile span == f
1693 leftmost_smallest (_,a) (_,b) = a `compare` b
1694 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1696 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1697 rightmost (_,a) (_,b) = b `compare` a
1699 spans :: SrcSpan -> (Int,Int) -> Bool
1700 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1701 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1703 start_bold = BS.pack "\ESC[1m"
1704 end_bold = BS.pack "\ESC[0m"
1706 listCmd :: String -> GHCi ()
1708 mb_span <- getCurrentBreakSpan
1710 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1711 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1712 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1713 listCmd str = list2 (words str)
1715 list2 [arg] | all isDigit arg = do
1716 session <- getSession
1717 (toplevel, _) <- io $ GHC.getContext session
1719 [] -> io $ putStrLn "No module to list"
1720 (mod : _) -> listModuleLine mod (read arg)
1721 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1722 mod <- wantInterpretedModule arg1
1723 listModuleLine mod (read arg2)
1725 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1726 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1727 if GHC.isGoodSrcLoc loc
1729 tickArray <- getTickArray (GHC.nameModule name)
1730 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1731 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1734 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1735 Just (_,span) -> io $ listAround span False
1737 noCanDo name $ text "can't find its location: " <>
1740 noCanDo n why = printForUser $
1741 text "cannot list source code for " <> ppr n <> text ": " <> why
1743 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1745 listModuleLine :: Module -> Int -> GHCi ()
1746 listModuleLine modl line = do
1747 session <- getSession
1748 graph <- io (GHC.getModuleGraph session)
1749 let this = filter ((== modl) . GHC.ms_mod) graph
1751 [] -> panic "listModuleLine"
1753 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1754 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1755 io $ listAround (GHC.srcLocSpan loc) False
1757 -- | list a section of a source file around a particular SrcSpan.
1758 -- If the highlight flag is True, also highlight the span using
1759 -- start_bold/end_bold.
1760 listAround span do_highlight = do
1761 contents <- BS.readFile (unpackFS file)
1763 lines = BS.split '\n' contents
1764 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1765 drop (line1 - 1 - pad_before) $ lines
1766 fst_line = max 1 (line1 - pad_before)
1767 line_nos = [ fst_line .. ]
1769 highlighted | do_highlight = zipWith highlight line_nos these_lines
1770 | otherwise = these_lines
1772 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1773 prefixed = zipWith BS.append bs_line_nos highlighted
1775 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1777 file = GHC.srcSpanFile span
1778 line1 = GHC.srcSpanStartLine span
1779 col1 = GHC.srcSpanStartCol span
1780 line2 = GHC.srcSpanEndLine span
1781 col2 = GHC.srcSpanEndCol span
1783 pad_before | line1 == 1 = 0
1788 | no == line1 && no == line2
1789 = let (a,r) = BS.splitAt col1 line
1790 (b,c) = BS.splitAt (col2-col1) r
1792 BS.concat [a,start_bold,b,end_bold,c]
1794 = let (a,b) = BS.splitAt col1 line in
1795 BS.concat [a, start_bold, b]
1797 = let (a,b) = BS.splitAt col2 line in
1798 BS.concat [a, end_bold, b]
1801 -- --------------------------------------------------------------------------
1804 getTickArray :: Module -> GHCi TickArray
1805 getTickArray modl = do
1807 let arrmap = tickarrays st
1808 case lookupModuleEnv arrmap modl of
1809 Just arr -> return arr
1811 (breakArray, ticks) <- getModBreak modl
1812 let arr = mkTickArray (assocs ticks)
1813 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1816 discardTickArrays :: GHCi ()
1817 discardTickArrays = do
1819 setGHCiState st{tickarrays = emptyModuleEnv}
1821 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1823 = accumArray (flip (:)) [] (1, max_line)
1824 [ (line, (nm,span)) | (nm,span) <- ticks,
1825 line <- srcSpanLines span ]
1827 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1828 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1829 GHC.srcSpanEndLine span ]
1831 lookupModule :: String -> GHCi Module
1832 lookupModule modName
1833 = do session <- getSession
1834 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1836 -- don't reset the counter back to zero?
1837 discardActiveBreakPoints :: GHCi ()
1838 discardActiveBreakPoints = do
1840 mapM (turnOffBreak.snd) (breaks st)
1841 setGHCiState $ st { breaks = [] }
1843 deleteBreak :: Int -> GHCi ()
1844 deleteBreak identity = do
1846 let oldLocations = breaks st
1847 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1849 then printForUser (text "Breakpoint" <+> ppr identity <+>
1850 text "does not exist")
1852 mapM (turnOffBreak.snd) this
1853 setGHCiState $ st { breaks = rest }
1855 turnOffBreak loc = do
1856 (arr, _) <- getModBreak (breakModule loc)
1857 io $ setBreakFlag False arr (breakTick loc)
1859 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1860 getModBreak mod = do
1861 session <- getSession
1862 Just mod_info <- io $ GHC.getModuleInfo session mod
1863 let modBreaks = GHC.modInfoModBreaks mod_info
1864 let array = GHC.modBreaks_flags modBreaks
1865 let ticks = GHC.modBreaks_locs modBreaks
1866 return (array, ticks)
1868 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1869 setBreakFlag toggle array index
1870 | toggle = GHC.setBreakOn array index
1871 | otherwise = GHC.setBreakOff array index