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 " :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 ()
727 -- find the name of the "topmost" file loaded
728 session <- getSession
729 graph0 <- io (GHC.getModuleGraph session)
730 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
731 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
732 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
733 Just file -> do_edit file
734 Nothing -> throwDyn (CmdLineError "unknown file name")
735 | otherwise = do_edit str
741 throwDyn (CmdLineError "editor not set, use :set editor")
742 io $ system (cmd ++ ' ':file)
745 defineMacro :: String -> GHCi ()
747 let (macro_name, definition) = break isSpace s
748 cmds <- io (readIORef commands)
750 then throwDyn (CmdLineError "invalid macro name")
752 if (macro_name `elem` map cmdName cmds)
753 then throwDyn (CmdLineError
754 ("command '" ++ macro_name ++ "' is already defined"))
757 -- give the expression a type signature, so we can be sure we're getting
758 -- something of the right type.
759 let new_expr = '(' : definition ++ ") :: String -> IO String"
761 -- compile the expression
763 maybe_hv <- io (GHC.compileExpr cms new_expr)
766 Just hv -> io (writeIORef commands --
767 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
769 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
771 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
772 enqueueCommands (lines str)
775 undefineMacro :: String -> GHCi ()
776 undefineMacro macro_name = do
777 cmds <- io (readIORef commands)
778 if (macro_name `elem` map cmdName builtin_commands)
779 then throwDyn (CmdLineError
780 ("command '" ++ macro_name ++ "' cannot be undefined"))
782 if (macro_name `notElem` map cmdName cmds)
783 then throwDyn (CmdLineError
784 ("command '" ++ macro_name ++ "' not defined"))
786 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
788 cmdCmd :: String -> GHCi ()
790 let expr = '(' : str ++ ") :: IO String"
791 session <- getSession
792 maybe_hv <- io (GHC.compileExpr session expr)
796 cmds <- io $ (unsafeCoerce# hv :: IO String)
797 enqueueCommands (lines cmds)
800 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
801 loadModule fs = timeIt (loadModule' fs)
803 loadModule_ :: [FilePath] -> GHCi ()
804 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
806 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
807 loadModule' files = do
808 session <- getSession
811 discardActiveBreakPoints
812 io (GHC.setTargets session [])
813 io (GHC.load session LoadAllTargets)
816 let (filenames, phases) = unzip files
817 exp_filenames <- mapM expandPath filenames
818 let files' = zip exp_filenames phases
819 targets <- io (mapM (uncurry GHC.guessTarget) files')
821 -- NOTE: we used to do the dependency anal first, so that if it
822 -- fails we didn't throw away the current set of modules. This would
823 -- require some re-working of the GHC interface, so we'll leave it
824 -- as a ToDo for now.
826 io (GHC.setTargets session targets)
827 doLoad session LoadAllTargets
829 checkModule :: String -> GHCi ()
831 let modl = GHC.mkModuleName m
832 session <- getSession
833 result <- io (GHC.checkModule session modl)
835 Nothing -> io $ putStrLn "Nothing"
836 Just r -> io $ putStrLn (showSDoc (
837 case GHC.checkedModuleInfo r of
838 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
840 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
842 (text "global names: " <+> ppr global) $$
843 (text "local names: " <+> ppr local)
845 afterLoad (successIf (isJust result)) session
847 reloadModule :: String -> GHCi ()
849 io (revertCAFs) -- always revert CAFs on reload.
850 discardActiveBreakPoints
851 session <- getSession
852 doLoad session LoadAllTargets
855 io (revertCAFs) -- always revert CAFs on reload.
856 discardActiveBreakPoints
857 session <- getSession
858 doLoad session (LoadUpTo (GHC.mkModuleName m))
861 doLoad session howmuch = do
862 -- turn off breakpoints before we load: we can't turn them off later, because
863 -- the ModBreaks will have gone away.
864 discardActiveBreakPoints
865 ok <- io (GHC.load session howmuch)
869 afterLoad ok session = do
870 io (revertCAFs) -- always revert CAFs on load.
872 graph <- io (GHC.getModuleGraph session)
873 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
874 setContextAfterLoad session graph'
875 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
877 setContextAfterLoad session [] = do
878 prel_mod <- getPrelude
879 io (GHC.setContext session [] [prel_mod])
880 setContextAfterLoad session ms = do
881 -- load a target if one is available, otherwise load the topmost module.
882 targets <- io (GHC.getTargets session)
883 case [ m | Just m <- map (findTarget ms) targets ] of
885 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
886 load_this (last graph')
891 = case filter (`matches` t) ms of
895 summary `matches` Target (TargetModule m) _
896 = GHC.ms_mod_name summary == m
897 summary `matches` Target (TargetFile f _) _
898 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
899 summary `matches` target
902 load_this summary | m <- GHC.ms_mod summary = do
903 b <- io (GHC.moduleIsInterpreted session m)
904 if b then io (GHC.setContext session [m] [])
906 prel_mod <- getPrelude
907 io (GHC.setContext session [] [prel_mod,m])
910 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
911 modulesLoadedMsg ok mods = do
912 dflags <- getDynFlags
913 when (verbosity dflags > 0) $ do
915 | null mods = text "none."
917 punctuate comma (map ppr mods)) <> text "."
920 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
922 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
925 typeOfExpr :: String -> GHCi ()
927 = do cms <- getSession
928 maybe_ty <- io (GHC.exprType cms str)
931 Just ty -> do ty' <- cleanType ty
932 printForUser $ text str <> text " :: " <> ppr ty'
934 kindOfType :: String -> GHCi ()
936 = do cms <- getSession
937 maybe_ty <- io (GHC.typeKind cms str)
940 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
942 quit :: String -> GHCi Bool
945 shellEscape :: String -> GHCi Bool
946 shellEscape str = io (system str >> return False)
948 -----------------------------------------------------------------------------
949 -- Browsing a module's contents
951 browseCmd :: String -> GHCi ()
954 ['*':m] | looksLikeModuleName m -> browseModule m False
955 [m] | looksLikeModuleName m -> browseModule m True
956 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
958 browseModule m exports_only = do
960 modl <- if exports_only then lookupModule m
961 else wantInterpretedModule m
963 -- Temporarily set the context to the module we're interested in,
964 -- just so we can get an appropriate PrintUnqualified
965 (as,bs) <- io (GHC.getContext s)
966 prel_mod <- getPrelude
967 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
968 else GHC.setContext s [modl] [])
969 unqual <- io (GHC.getPrintUnqual s)
970 io (GHC.setContext s as bs)
972 mb_mod_info <- io $ GHC.getModuleInfo s modl
974 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
977 | exports_only = GHC.modInfoExports mod_info
978 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
980 filtered = filterOutChildren names
982 things <- io $ mapM (GHC.lookupName s) filtered
984 dflags <- getDynFlags
985 let exts = dopt Opt_GlasgowExts dflags
986 io (putStrLn (showSDocForUser unqual (
987 vcat (map (pprTyThingInContext exts) (catMaybes things))
989 -- ToDo: modInfoInstances currently throws an exception for
990 -- package modules. When it works, we can do this:
991 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
993 -----------------------------------------------------------------------------
994 -- Setting the module context
997 | all sensible mods = fn mods
998 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1000 (fn, mods) = case str of
1001 '+':stuff -> (addToContext, words stuff)
1002 '-':stuff -> (removeFromContext, words stuff)
1003 stuff -> (newContext, words stuff)
1005 sensible ('*':m) = looksLikeModuleName m
1006 sensible m = looksLikeModuleName m
1008 separate :: Session -> [String] -> [Module] -> [Module]
1009 -> GHCi ([Module],[Module])
1010 separate session [] as bs = return (as,bs)
1011 separate session (('*':str):ms) as bs = do
1012 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1013 b <- io $ GHC.moduleIsInterpreted session m
1014 if b then separate session ms (m:as) bs
1015 else throwDyn (CmdLineError ("module '"
1016 ++ GHC.moduleNameString (GHC.moduleName m)
1017 ++ "' is not interpreted"))
1018 separate session (str:ms) as bs = do
1019 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1020 separate session ms as (m:bs)
1022 newContext :: [String] -> GHCi ()
1023 newContext strs = do
1025 (as,bs) <- separate s strs [] []
1026 prel_mod <- getPrelude
1027 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1028 io $ GHC.setContext s as bs'
1031 addToContext :: [String] -> GHCi ()
1032 addToContext strs = do
1034 (as,bs) <- io $ GHC.getContext s
1036 (new_as,new_bs) <- separate s strs [] []
1038 let as_to_add = new_as \\ (as ++ bs)
1039 bs_to_add = new_bs \\ (as ++ bs)
1041 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1044 removeFromContext :: [String] -> GHCi ()
1045 removeFromContext strs = do
1047 (as,bs) <- io $ GHC.getContext s
1049 (as_to_remove,bs_to_remove) <- separate s strs [] []
1051 let as' = as \\ (as_to_remove ++ bs_to_remove)
1052 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1054 io $ GHC.setContext s as' bs'
1056 ----------------------------------------------------------------------------
1059 -- set options in the interpreter. Syntax is exactly the same as the
1060 -- ghc command line, except that certain options aren't available (-C,
1063 -- This is pretty fragile: most options won't work as expected. ToDo:
1064 -- figure out which ones & disallow them.
1066 setCmd :: String -> GHCi ()
1068 = do st <- getGHCiState
1069 let opts = options st
1070 io $ putStrLn (showSDoc (
1071 text "options currently set: " <>
1074 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1077 = case toArgs str of
1078 ("args":args) -> setArgs args
1079 ("prog":prog) -> setProg prog
1080 ("prompt":prompt) -> setPrompt (after 6)
1081 ("editor":cmd) -> setEditor (after 6)
1082 ("stop":cmd) -> setStop (after 4)
1083 wds -> setOptions wds
1084 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1088 setGHCiState st{ args = args }
1092 setGHCiState st{ progname = prog }
1094 io (hPutStrLn stderr "syntax: :set prog <progname>")
1098 setGHCiState st{ editor = cmd }
1100 setStop str@(c:_) | isDigit c
1101 = do let (nm_str,rest) = break (not.isDigit) str
1104 let old_breaks = breaks st
1105 if all ((/= nm) . fst) old_breaks
1106 then printForUser (text "Breakpoint" <+> ppr nm <+>
1107 text "does not exist")
1109 let new_breaks = map fn old_breaks
1110 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1111 | otherwise = (i,loc)
1112 setGHCiState st{ breaks = new_breaks }
1115 setGHCiState st{ stop = cmd }
1117 setPrompt value = do
1120 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1121 else setGHCiState st{ prompt = remQuotes value }
1123 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1127 do -- first, deal with the GHCi opts (+s, +t, etc.)
1128 let (plus_opts, minus_opts) = partition isPlus wds
1129 mapM_ setOpt plus_opts
1130 -- then, dynamic flags
1131 newDynFlags minus_opts
1133 newDynFlags minus_opts = do
1134 dflags <- getDynFlags
1135 let pkg_flags = packageFlags dflags
1136 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1138 if (not (null leftovers))
1139 then throwDyn (CmdLineError ("unrecognised flags: " ++
1143 new_pkgs <- setDynFlags dflags'
1145 -- if the package flags changed, we should reset the context
1146 -- and link the new packages.
1147 dflags <- getDynFlags
1148 when (packageFlags dflags /= pkg_flags) $ do
1149 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1150 session <- getSession
1151 io (GHC.setTargets session [])
1152 io (GHC.load session LoadAllTargets)
1153 io (linkPackages dflags new_pkgs)
1154 setContextAfterLoad session []
1158 unsetOptions :: String -> GHCi ()
1160 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1161 let opts = words str
1162 (minus_opts, rest1) = partition isMinus opts
1163 (plus_opts, rest2) = partition isPlus rest1
1165 if (not (null rest2))
1166 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1169 mapM_ unsetOpt plus_opts
1171 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1172 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1174 no_flags <- mapM no_flag minus_opts
1175 newDynFlags no_flags
1177 isMinus ('-':s) = True
1180 isPlus ('+':s) = True
1184 = case strToGHCiOpt str of
1185 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1186 Just o -> setOption o
1189 = case strToGHCiOpt str of
1190 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1191 Just o -> unsetOption o
1193 strToGHCiOpt :: String -> (Maybe GHCiOption)
1194 strToGHCiOpt "s" = Just ShowTiming
1195 strToGHCiOpt "t" = Just ShowType
1196 strToGHCiOpt "r" = Just RevertCAFs
1197 strToGHCiOpt _ = Nothing
1199 optToStr :: GHCiOption -> String
1200 optToStr ShowTiming = "s"
1201 optToStr ShowType = "t"
1202 optToStr RevertCAFs = "r"
1204 -- ---------------------------------------------------------------------------
1210 ["args"] -> io $ putStrLn (show (args st))
1211 ["prog"] -> io $ putStrLn (show (progname st))
1212 ["prompt"] -> io $ putStrLn (show (prompt st))
1213 ["editor"] -> io $ putStrLn (show (editor st))
1214 ["stop"] -> io $ putStrLn (show (stop st))
1215 ["modules" ] -> showModules
1216 ["bindings"] -> showBindings
1217 ["linker"] -> io showLinkerState
1218 ["breaks"] -> showBkptTable
1219 ["context"] -> showContext
1220 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1223 session <- getSession
1224 let show_one ms = do m <- io (GHC.showModule session ms)
1226 graph <- io (GHC.getModuleGraph session)
1227 mapM_ show_one graph
1231 unqual <- io (GHC.getPrintUnqual s)
1232 bindings <- io (GHC.getBindings s)
1233 mapM_ showTyThing bindings
1236 showTyThing (AnId id) = do
1237 ty' <- cleanType (GHC.idType id)
1238 printForUser $ ppr id <> text " :: " <> ppr ty'
1239 showTyThing _ = return ()
1241 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1242 cleanType :: Type -> GHCi Type
1244 dflags <- getDynFlags
1245 if dopt Opt_GlasgowExts dflags
1247 else return $! GHC.dropForAlls ty
1249 showBkptTable :: GHCi ()
1252 printForUser $ prettyLocations (breaks st)
1254 showContext :: GHCi ()
1256 session <- getSession
1257 resumes <- io $ GHC.getResumeContext session
1258 printForUser $ vcat (map pp_resume (reverse resumes))
1261 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1262 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1265 -- -----------------------------------------------------------------------------
1268 completeNone :: String -> IO [String]
1269 completeNone w = return []
1272 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1273 completeWord w start end = do
1274 line <- Readline.getLineBuffer
1276 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1278 | Just c <- is_cmd line -> do
1279 maybe_cmd <- lookupCommand c
1280 let (n,w') = selectWord (words' 0 line)
1282 Nothing -> return Nothing
1283 Just (_,_,False,complete) -> wrapCompleter complete w
1284 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1285 return (map (drop n) rets)
1286 in wrapCompleter complete' w'
1288 --printf "complete %s, start = %d, end = %d\n" w start end
1289 wrapCompleter completeIdentifier w
1290 where words' _ [] = []
1291 words' n str = let (w,r) = break isSpace str
1292 (s,r') = span isSpace r
1293 in (n,w):words' (n+length w+length s) r'
1294 -- In a Haskell expression we want to parse 'a-b' as three words
1295 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1296 -- only be a single word.
1297 selectWord [] = (0,w)
1298 selectWord ((offset,x):xs)
1299 | offset+length x >= start = (start-offset,take (end-offset) x)
1300 | otherwise = selectWord xs
1303 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1304 | otherwise = Nothing
1307 cmds <- readIORef commands
1308 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1310 completeMacro w = do
1311 cmds <- readIORef commands
1312 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1313 return (filter (w `isPrefixOf`) cmds')
1315 completeIdentifier w = do
1317 rdrs <- GHC.getRdrNamesInScope s
1318 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1320 completeModule w = do
1322 dflags <- GHC.getSessionDynFlags s
1323 let pkg_mods = allExposedModules dflags
1324 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1326 completeHomeModule w = do
1328 g <- GHC.getModuleGraph s
1329 let home_mods = map GHC.ms_mod_name g
1330 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1332 completeSetOptions w = do
1333 return (filter (w `isPrefixOf`) options)
1334 where options = "args":"prog":allFlags
1336 completeFilename = Readline.filenameCompletionFunction
1338 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1340 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1341 unionComplete f1 f2 w = do
1346 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1347 wrapCompleter fun w = do
1350 [] -> return Nothing
1351 [x] -> return (Just (x,[]))
1352 xs -> case getCommonPrefix xs of
1353 "" -> return (Just ("",xs))
1354 pref -> return (Just (pref,xs))
1356 getCommonPrefix :: [String] -> String
1357 getCommonPrefix [] = ""
1358 getCommonPrefix (s:ss) = foldl common s ss
1359 where common s "" = ""
1361 common (c:cs) (d:ds)
1362 | c == d = c : common cs ds
1365 allExposedModules :: DynFlags -> [ModuleName]
1366 allExposedModules dflags
1367 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1369 pkg_db = pkgIdMap (pkgState dflags)
1371 completeCmd = completeNone
1372 completeMacro = completeNone
1373 completeIdentifier = completeNone
1374 completeModule = completeNone
1375 completeHomeModule = completeNone
1376 completeSetOptions = completeNone
1377 completeFilename = completeNone
1378 completeHomeModuleOrFile=completeNone
1379 completeBkpt = completeNone
1382 -- ---------------------------------------------------------------------------
1383 -- User code exception handling
1385 -- This is the exception handler for exceptions generated by the
1386 -- user's code and exceptions coming from children sessions;
1387 -- it normally just prints out the exception. The
1388 -- handler must be recursive, in case showing the exception causes
1389 -- more exceptions to be raised.
1391 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1392 -- raising another exception. We therefore don't put the recursive
1393 -- handler arond the flushing operation, so if stderr is closed
1394 -- GHCi will just die gracefully rather than going into an infinite loop.
1395 handler :: Exception -> GHCi Bool
1397 handler exception = do
1399 io installSignalHandlers
1400 ghciHandle handler (showException exception >> return False)
1402 showException (DynException dyn) =
1403 case fromDynamic dyn of
1404 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1405 Just Interrupted -> io (putStrLn "Interrupted.")
1406 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1407 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1408 Just other_ghc_ex -> io (print other_ghc_ex)
1410 showException other_exception
1411 = io (putStrLn ("*** Exception: " ++ show other_exception))
1413 -----------------------------------------------------------------------------
1414 -- recursive exception handlers
1416 -- Don't forget to unblock async exceptions in the handler, or if we're
1417 -- in an exception loop (eg. let a = error a in a) the ^C exception
1418 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1420 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1421 ghciHandle h (GHCi m) = GHCi $ \s ->
1422 Exception.catch (m s)
1423 (\e -> unGHCi (ghciUnblock (h e)) s)
1425 ghciUnblock :: GHCi a -> GHCi a
1426 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1429 -- ----------------------------------------------------------------------------
1432 expandPath :: String -> GHCi String
1434 case dropWhile isSpace path of
1436 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1437 return (tilde ++ '/':d)
1441 wantInterpretedModule :: String -> GHCi Module
1442 wantInterpretedModule str = do
1443 session <- getSession
1444 modl <- lookupModule str
1445 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1446 when (not is_interpreted) $
1447 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1450 wantNameFromInterpretedModule noCanDo str and_then = do
1451 session <- getSession
1452 names <- io $ GHC.parseName session str
1456 let modl = GHC.nameModule n
1457 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1458 if not is_interpreted
1459 then noCanDo n $ text "module " <> ppr modl <>
1460 text " is not interpreted"
1463 -- ----------------------------------------------------------------------------
1464 -- Windows console setup
1466 setUpConsole :: IO ()
1468 #ifdef mingw32_HOST_OS
1469 -- On Windows we need to set a known code page, otherwise the characters
1470 -- we read from the console will be be in some strange encoding, and
1471 -- similarly for characters we write to the console.
1473 -- At the moment, GHCi pretends all input is Latin-1. In the
1474 -- future we should support UTF-8, but for now we set the code pages
1477 -- It seems you have to set the font in the console window to
1478 -- a Unicode font in order for output to work properly,
1479 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1480 -- (see MSDN for SetConsoleOutputCP()).
1482 setConsoleCP 28591 -- ISO Latin-1
1483 setConsoleOutputCP 28591 -- ISO Latin-1
1487 -- -----------------------------------------------------------------------------
1488 -- commands for debugger
1490 sprintCmd = pprintCommand False False
1491 printCmd = pprintCommand True False
1492 forceCmd = pprintCommand False True
1494 pprintCommand bind force str = do
1495 session <- getSession
1496 io $ pprintClosureCommand session bind force str
1498 stepCmd :: String -> GHCi ()
1499 stepCmd [] = doContinue GHC.SingleStep
1500 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1502 traceCmd :: String -> GHCi ()
1503 traceCmd [] = doContinue GHC.RunAndLogSteps
1504 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1506 continueCmd :: String -> GHCi ()
1507 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1509 doContinue :: SingleStep -> GHCi ()
1510 doContinue step = do
1511 session <- getSession
1512 runResult <- io $ GHC.resume session step
1513 afterRunStmt runResult
1516 abandonCmd :: String -> GHCi ()
1517 abandonCmd = noArgs $ do
1519 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1520 when (not b) $ io $ putStrLn "There is no computation running."
1523 deleteCmd :: String -> GHCi ()
1524 deleteCmd argLine = do
1525 deleteSwitch $ words argLine
1527 deleteSwitch :: [String] -> GHCi ()
1529 io $ putStrLn "The delete command requires at least one argument."
1530 -- delete all break points
1531 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1532 deleteSwitch idents = do
1533 mapM_ deleteOneBreak idents
1535 deleteOneBreak :: String -> GHCi ()
1537 | all isDigit str = deleteBreak (read str)
1538 | otherwise = return ()
1540 historyCmd :: String -> GHCi ()
1542 | null arg = history 20
1543 | all isDigit arg = history (read arg)
1544 | otherwise = io $ putStrLn "Syntax: :history [num]"
1548 resumes <- io $ GHC.getResumeContext s
1550 [] -> io $ putStrLn "Not stopped at a breakpoint"
1552 let hist = GHC.resumeHistory r
1553 (took,rest) = splitAt num hist
1554 spans <- mapM (io . GHC.getHistorySpan s) took
1555 let nums = map (printf "-%-3d:") [(1::Int)..]
1556 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1557 io $ putStrLn $ if null rest then "<end of history>" else "..."
1559 backCmd :: String -> GHCi ()
1560 backCmd = noArgs $ do
1562 (names, ix, span) <- io $ GHC.back s
1563 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1564 mapM_ (showTypeOfName s) names
1565 -- run the command set with ":set stop <cmd>"
1567 enqueueCommands [stop st]
1569 forwardCmd :: String -> GHCi ()
1570 forwardCmd = noArgs $ do
1572 (names, ix, span) <- io $ GHC.forward s
1573 printForUser $ (if (ix == 0)
1574 then ptext SLIT("Stopped at")
1575 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1576 mapM_ (showTypeOfName s) names
1577 -- run the command set with ":set stop <cmd>"
1579 enqueueCommands [stop st]
1581 -- handle the "break" command
1582 breakCmd :: String -> GHCi ()
1583 breakCmd argLine = do
1584 session <- getSession
1585 breakSwitch session $ words argLine
1587 breakSwitch :: Session -> [String] -> GHCi ()
1588 breakSwitch _session [] = do
1589 io $ putStrLn "The break command requires at least one argument."
1590 breakSwitch session args@(arg1:rest)
1591 | looksLikeModuleName arg1 = do
1592 mod <- wantInterpretedModule arg1
1593 breakByModule session mod rest
1594 | all isDigit arg1 = do
1595 (toplevel, _) <- io $ GHC.getContext session
1597 (mod : _) -> breakByModuleLine mod (read arg1) rest
1599 io $ putStrLn "Cannot find default module for breakpoint."
1600 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1601 | otherwise = do -- try parsing it as an identifier
1602 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1603 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1604 if GHC.isGoodSrcLoc loc
1605 then findBreakAndSet (GHC.nameModule name) $
1606 findBreakByCoord (Just (GHC.srcLocFile loc))
1607 (GHC.srcLocLine loc,
1609 else noCanDo name $ text "can't find its location: " <> ppr loc
1611 noCanDo n why = printForUser $
1612 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1614 breakByModule :: Session -> Module -> [String] -> GHCi ()
1615 breakByModule session mod args@(arg1:rest)
1616 | all isDigit arg1 = do -- looks like a line number
1617 breakByModuleLine mod (read arg1) rest
1618 | otherwise = io $ putStrLn "Invalid arguments to :break"
1620 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1621 breakByModuleLine mod line args
1622 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1623 | [col] <- args, all isDigit col =
1624 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1625 | otherwise = io $ putStrLn "Invalid arguments to :break"
1627 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1628 findBreakAndSet mod lookupTickTree = do
1629 tickArray <- getTickArray mod
1630 (breakArray, _) <- getModBreak mod
1631 case lookupTickTree tickArray of
1632 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1633 Just (tick, span) -> do
1634 success <- io $ setBreakFlag True breakArray tick
1635 session <- getSession
1639 recordBreak $ BreakLocation
1646 text "Breakpoint " <> ppr nm <>
1648 then text " was already set at " <> ppr span
1649 else text " activated at " <> ppr span
1651 printForUser $ text "Breakpoint could not be activated at"
1654 -- When a line number is specified, the current policy for choosing
1655 -- the best breakpoint is this:
1656 -- - the leftmost complete subexpression on the specified line, or
1657 -- - the leftmost subexpression starting on the specified line, or
1658 -- - the rightmost subexpression enclosing the specified line
1660 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1661 findBreakByLine line arr
1662 | not (inRange (bounds arr) line) = Nothing
1664 listToMaybe (sortBy leftmost_largest complete) `mplus`
1665 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1666 listToMaybe (sortBy rightmost ticks)
1670 starts_here = [ tick | tick@(nm,span) <- ticks,
1671 GHC.srcSpanStartLine span == line ]
1673 (complete,incomplete) = partition ends_here starts_here
1674 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1676 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1677 -> Maybe (BreakIndex,SrcSpan)
1678 findBreakByCoord mb_file (line, col) arr
1679 | not (inRange (bounds arr) line) = Nothing
1681 listToMaybe (sortBy rightmost contains) `mplus`
1682 listToMaybe (sortBy leftmost_smallest after_here)
1686 -- the ticks that span this coordinate
1687 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1688 is_correct_file span ]
1690 is_correct_file span
1691 | Just f <- mb_file = GHC.srcSpanFile span == f
1694 after_here = [ tick | tick@(nm,span) <- ticks,
1695 GHC.srcSpanStartLine span == line,
1696 GHC.srcSpanStartCol span >= col ]
1699 leftmost_smallest (_,a) (_,b) = a `compare` b
1700 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1702 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1703 rightmost (_,a) (_,b) = b `compare` a
1705 spans :: SrcSpan -> (Int,Int) -> Bool
1706 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1707 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1709 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1710 -- of carets under the active expression instead. The Windows console
1711 -- doesn't support ANSI escape sequences, and most Unix terminals
1712 -- (including xterm) do, so this is a reasonable guess until we have a
1713 -- proper termcap/terminfo library.
1714 #if !defined(mingw32_TARGET_OS)
1720 start_bold = BS.pack "\ESC[1m"
1721 end_bold = BS.pack "\ESC[0m"
1723 listCmd :: String -> GHCi ()
1725 mb_span <- getCurrentBreakSpan
1727 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1728 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1729 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1730 listCmd str = list2 (words str)
1732 list2 [arg] | all isDigit arg = do
1733 session <- getSession
1734 (toplevel, _) <- io $ GHC.getContext session
1736 [] -> io $ putStrLn "No module to list"
1737 (mod : _) -> listModuleLine mod (read arg)
1738 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1739 mod <- wantInterpretedModule arg1
1740 listModuleLine mod (read arg2)
1742 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1743 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1744 if GHC.isGoodSrcLoc loc
1746 tickArray <- getTickArray (GHC.nameModule name)
1747 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1748 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1751 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1752 Just (_,span) -> io $ listAround span False
1754 noCanDo name $ text "can't find its location: " <>
1757 noCanDo n why = printForUser $
1758 text "cannot list source code for " <> ppr n <> text ": " <> why
1760 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1762 listModuleLine :: Module -> Int -> GHCi ()
1763 listModuleLine modl line = do
1764 session <- getSession
1765 graph <- io (GHC.getModuleGraph session)
1766 let this = filter ((== modl) . GHC.ms_mod) graph
1768 [] -> panic "listModuleLine"
1770 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1771 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1772 io $ listAround (GHC.srcLocSpan loc) False
1774 -- | list a section of a source file around a particular SrcSpan.
1775 -- If the highlight flag is True, also highlight the span using
1776 -- start_bold/end_bold.
1777 listAround span do_highlight = do
1778 contents <- BS.readFile (unpackFS file)
1780 lines = BS.split '\n' contents
1781 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1782 drop (line1 - 1 - pad_before) $ lines
1783 fst_line = max 1 (line1 - pad_before)
1784 line_nos = [ fst_line .. ]
1786 highlighted | do_highlight = zipWith highlight line_nos these_lines
1787 | otherwise = these_lines
1789 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1790 prefixed = zipWith BS.append bs_line_nos highlighted
1792 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1794 file = GHC.srcSpanFile span
1795 line1 = GHC.srcSpanStartLine span
1796 col1 = GHC.srcSpanStartCol span
1797 line2 = GHC.srcSpanEndLine span
1798 col2 = GHC.srcSpanEndCol span
1800 pad_before | line1 == 1 = 0
1804 highlight | do_bold = highlight_bold
1805 | otherwise = highlight_carets
1807 highlight_bold no line
1808 | no == line1 && no == line2
1809 = let (a,r) = BS.splitAt col1 line
1810 (b,c) = BS.splitAt (col2-col1) r
1812 BS.concat [a,start_bold,b,end_bold,c]
1814 = let (a,b) = BS.splitAt col1 line in
1815 BS.concat [a, start_bold, b]
1817 = let (a,b) = BS.splitAt col2 line in
1818 BS.concat [a, end_bold, b]
1821 highlight_carets no line
1822 | no == line1 && no == line2
1823 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1824 BS.replicate (col2-col1) '^']
1826 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1827 BS.replicate (BS.length line-col1) '^']
1829 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1832 indent = BS.pack " "
1833 nl = BS.singleton '\n'
1835 -- --------------------------------------------------------------------------
1838 getTickArray :: Module -> GHCi TickArray
1839 getTickArray modl = do
1841 let arrmap = tickarrays st
1842 case lookupModuleEnv arrmap modl of
1843 Just arr -> return arr
1845 (breakArray, ticks) <- getModBreak modl
1846 let arr = mkTickArray (assocs ticks)
1847 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1850 discardTickArrays :: GHCi ()
1851 discardTickArrays = do
1853 setGHCiState st{tickarrays = emptyModuleEnv}
1855 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1857 = accumArray (flip (:)) [] (1, max_line)
1858 [ (line, (nm,span)) | (nm,span) <- ticks,
1859 line <- srcSpanLines span ]
1861 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1862 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1863 GHC.srcSpanEndLine span ]
1865 lookupModule :: String -> GHCi Module
1866 lookupModule modName
1867 = do session <- getSession
1868 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1870 -- don't reset the counter back to zero?
1871 discardActiveBreakPoints :: GHCi ()
1872 discardActiveBreakPoints = do
1874 mapM (turnOffBreak.snd) (breaks st)
1875 setGHCiState $ st { breaks = [] }
1877 deleteBreak :: Int -> GHCi ()
1878 deleteBreak identity = do
1880 let oldLocations = breaks st
1881 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1883 then printForUser (text "Breakpoint" <+> ppr identity <+>
1884 text "does not exist")
1886 mapM (turnOffBreak.snd) this
1887 setGHCiState $ st { breaks = rest }
1889 turnOffBreak loc = do
1890 (arr, _) <- getModBreak (breakModule loc)
1891 io $ setBreakFlag False arr (breakTick loc)
1893 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1894 getModBreak mod = do
1895 session <- getSession
1896 Just mod_info <- io $ GHC.getModuleInfo session mod
1897 let modBreaks = GHC.modInfoModBreaks mod_info
1898 let array = GHC.modBreaks_flags modBreaks
1899 let ticks = GHC.modBreaks_locs modBreaks
1900 return (array, ticks)
1902 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1903 setBreakFlag toggle array index
1904 | toggle = GHC.setBreakOn array index
1905 | otherwise = GHC.setBreakOff array index