1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, Name, SrcSpan, Resume, SingleStep )
27 import Outputable hiding (printForUser)
28 import Module -- for ModuleEnv
30 -- Other random utilities
32 import BasicTypes hiding (isTopLevel)
33 import Panic hiding (showException)
40 #ifndef mingw32_HOST_OS
41 import System.Posix hiding (getEnv)
43 import GHC.ConsoleHandler ( flushConsole )
44 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
45 import qualified System.Win32
49 import Control.Concurrent ( yield ) -- Used in readline loop
50 import System.Console.Readline as Readline
55 import Control.Exception as Exception
56 -- import Control.Concurrent
58 import qualified Data.ByteString.Char8 as BS
62 import System.Environment
63 import System.Exit ( exitWith, ExitCode(..) )
64 import System.Directory
66 import System.IO.Error as IO
70 import Control.Monad as Monad
73 import Foreign.StablePtr ( newStablePtr )
74 import GHC.Exts ( unsafeCoerce# )
75 import GHC.IOBase ( IOErrorType(InvalidArgument) )
77 import Data.IORef ( IORef, readIORef, writeIORef )
79 import System.Posix.Internals ( setNonBlockingFD )
81 -----------------------------------------------------------------------------
85 " / _ \\ /\\ /\\/ __(_)\n"++
86 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
87 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
88 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
91 "GHCi, version " ++ cProjectVersion ++
92 ": http://www.haskell.org/ghc/ :? for help"
94 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
97 GLOBAL_VAR(commands, builtin_commands, [Command])
99 builtin_commands :: [Command]
101 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
102 ("?", keepGoing help, False, completeNone),
103 ("add", keepGoingPaths addModule, False, completeFilename),
104 ("abandon", keepGoing abandonCmd, False, completeNone),
105 ("break", keepGoing breakCmd, False, completeIdentifier),
106 ("back", keepGoing backCmd, False, completeNone),
107 ("browse", keepGoing browseCmd, False, completeModule),
108 ("cd", keepGoing changeDirectory, False, completeFilename),
109 ("check", keepGoing checkModule, False, completeHomeModule),
110 ("continue", keepGoing continueCmd, False, completeNone),
111 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
112 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
113 ("def", keepGoing defineMacro, False, completeIdentifier),
114 ("delete", keepGoing deleteCmd, False, completeNone),
115 ("e", keepGoing editFile, False, completeFilename),
116 ("edit", keepGoing editFile, False, completeFilename),
117 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
118 ("force", keepGoing forceCmd, False, completeIdentifier),
119 ("forward", keepGoing forwardCmd, False, completeNone),
120 ("help", keepGoing help, False, completeNone),
121 ("history", keepGoing historyCmd, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("kind", keepGoing kindOfType, False, completeIdentifier),
124 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
125 ("list", keepGoing listCmd, False, completeNone),
126 ("module", keepGoing setContext, False, completeModule),
127 ("main", keepGoing runMain, False, completeIdentifier),
128 ("print", keepGoing printCmd, False, completeIdentifier),
129 ("quit", quit, False, completeNone),
130 ("reload", keepGoing reloadModule, False, completeNone),
131 ("set", keepGoing setCmd, True, completeSetOptions),
132 ("show", keepGoing showCmd, False, completeNone),
133 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
134 ("step", keepGoing stepCmd, False, completeIdentifier),
135 ("type", keepGoing typeOfExpr, False, completeIdentifier),
136 ("trace", keepGoing traceCmd, False, completeIdentifier),
137 ("undef", keepGoing undefineMacro, False, completeMacro),
138 ("unset", keepGoing unsetOptions, True, completeSetOptions)
141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoing a str = a str >> return False
144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoingPaths a str = a (toArgs str) >> return False
147 shortHelpText = "use :? for help.\n"
150 " Commands available from the prompt:\n" ++
152 " <statement> evaluate/run <statement>\n" ++
153 " :add <filename> ... add module(s) to the current target set\n" ++
154 " :browse [*]<module> display the names defined by <module>\n" ++
155 " :cd <dir> change directory to <dir>\n" ++
156 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
157 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
158 " :def <cmd> <expr> define a command :<cmd>\n" ++
159 " :edit <file> edit file\n" ++
160 " :edit edit last module\n" ++
161 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
162 " :help, :? display this list of commands\n" ++
163 " :info [<name> ...] display information about the given names\n" ++
164 " :kind <type> show the kind of <type>\n" ++
165 " :load <filename> ... load module(s) and their dependents\n" ++
166 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
167 " :main [<arguments> ...] run the main function with the given arguments\n" ++
168 " :quit exit GHCi\n" ++
169 " :reload reload the current module set\n" ++
170 " :type <expr> show the type of <expr>\n" ++
171 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
172 " :!<command> run the shell command <command>\n" ++
174 " -- Commands for debugging:\n" ++
176 " :abandon at a breakpoint, abandon current computation\n" ++
177 " :back go back in the history (after :trace)\n" ++
178 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
179 " :break <name> set a breakpoint on the specified function\n" ++
180 " :continue resume after a breakpoint\n" ++
181 " :delete <number> delete the specified breakpoint\n" ++
182 " :delete * delete all breakpoints\n" ++
183 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
184 " :forward go forward in the history (after :back)\n" ++
185 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
186 " :print [<name> ...] prints a value without forcing its computation\n" ++
187 " :sprint [<name> ...] simplifed version of :print\n" ++
188 " :step single-step after stopping at a breakpoint\n"++
189 " :step <expr> single-step into <expr>\n"++
190 " :trace trace after stopping at a breakpoint\n"++
191 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
194 " -- Commands for changing settings:\n" ++
196 " :set <option> ... set options\n" ++
197 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
198 " :set prog <progname> set the value returned by System.getProgName\n" ++
199 " :set prompt <prompt> set the prompt used in GHCi\n" ++
200 " :set editor <cmd> set the command used for :edit\n" ++
201 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
202 " :unset <option> ... unset options\n" ++
204 " Options for ':set' and ':unset':\n" ++
206 " +r revert top-level expressions after each evaluation\n" ++
207 " +s print timing/memory stats after each evaluation\n" ++
208 " +t print type after evaluation\n" ++
209 " -<flags> most GHC command line flags can also be set here\n" ++
210 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
212 " -- Commands for displaying information:\n" ++
214 " :show bindings show the current bindings made at the prompt\n" ++
215 " :show breaks show the active breakpoints\n" ++
216 " :show context show the breakpoint context\n" ++
217 " :show modules show the currently loaded modules\n" ++
218 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
225 win <- System.Win32.getWindowsDirectory
226 return (win `joinFileName` "notepad.exe")
231 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
232 interactiveUI session srcs maybe_expr = do
233 -- HACK! If we happen to get into an infinite loop (eg the user
234 -- types 'let x=x in x' at the prompt), then the thread will block
235 -- on a blackhole, and become unreachable during GC. The GC will
236 -- detect that it is unreachable and send it the NonTermination
237 -- exception. However, since the thread is unreachable, everything
238 -- it refers to might be finalized, including the standard Handles.
239 -- This sounds like a bug, but we don't have a good solution right
245 -- Initialise buffering for the *interpreted* I/O system
246 initInterpBuffering session
248 when (isNothing maybe_expr) $ do
249 -- Only for GHCi (not runghc and ghc -e):
251 -- Turn buffering off for the compiled program's stdout/stderr
253 -- Turn buffering off for GHCi's stdout
255 hSetBuffering stdout NoBuffering
256 -- We don't want the cmd line to buffer any input that might be
257 -- intended for the program, so unbuffer stdin.
258 hSetBuffering stdin NoBuffering
260 -- initial context is just the Prelude
261 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
262 GHC.setContext session [] [prel_mod]
266 Readline.setAttemptedCompletionFunction (Just completeWord)
267 --Readline.parseAndBind "set show-all-if-ambiguous 1"
269 let symbols = "!#$%&*+/<=>?@\\^|-~"
270 specials = "(),;[]`{}"
272 word_break_chars = spaces ++ specials ++ symbols
274 Readline.setBasicWordBreakCharacters word_break_chars
275 Readline.setCompleterWordBreakCharacters word_break_chars
278 default_editor <- findEditor
280 startGHCi (runGHCi srcs maybe_expr)
281 GHCiState{ progname = "<interactive>",
285 editor = default_editor,
291 tickarrays = emptyModuleEnv,
296 Readline.resetTerminal Nothing
301 prel_name = GHC.mkModuleName "Prelude"
303 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
304 runGHCi paths maybe_expr = do
305 let read_dot_files = not opt_IgnoreDotGhci
307 when (read_dot_files) $ do
310 exists <- io (doesFileExist file)
312 dir_ok <- io (checkPerms ".")
313 file_ok <- io (checkPerms file)
314 when (dir_ok && file_ok) $ do
315 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
318 Right hdl -> fileLoop hdl False
320 when (read_dot_files) $ do
321 -- Read in $HOME/.ghci
322 either_dir <- io (IO.try (getEnv "HOME"))
326 cwd <- io (getCurrentDirectory)
327 when (dir /= cwd) $ do
328 let file = dir ++ "/.ghci"
329 ok <- io (checkPerms file)
331 either_hdl <- io (IO.try (openFile file ReadMode))
334 Right hdl -> fileLoop hdl False
336 -- Perform a :load for files given on the GHCi command line
337 -- When in -e mode, if the load fails then we want to stop
338 -- immediately rather than going on to evaluate the expression.
339 when (not (null paths)) $ do
340 ok <- ghciHandle (\e -> do showException e; return Failed) $
342 when (isJust maybe_expr && failed ok) $
343 io (exitWith (ExitFailure 1))
345 -- if verbosity is greater than 0, or we are connected to a
346 -- terminal, display the prompt in the interactive loop.
347 is_tty <- io (hIsTerminalDevice stdin)
348 dflags <- getDynFlags
349 let show_prompt = verbosity dflags > 0 || is_tty
354 #if defined(mingw32_HOST_OS)
355 -- The win32 Console API mutates the first character of
356 -- type-ahead when reading from it in a non-buffered manner. Work
357 -- around this by flushing the input buffer of type-ahead characters,
358 -- but only if stdin is available.
359 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
361 Left err | isDoesNotExistError err -> return ()
362 | otherwise -> io (ioError err)
363 Right () -> return ()
365 -- initialise the console if necessary
368 let msg = if dopt Opt_ShortGhciBanner dflags
369 then ghciShortWelcomeMsg
371 when (verbosity dflags >= 1) $ io $ putStrLn msg
373 -- enter the interactive loop
374 interactiveLoop is_tty show_prompt
376 -- just evaluate the expression we were given
381 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
384 interactiveLoop is_tty show_prompt =
385 -- Ignore ^C exceptions caught here
386 ghciHandleDyn (\e -> case e of
388 #if defined(mingw32_HOST_OS)
391 interactiveLoop is_tty show_prompt
392 _other -> return ()) $
394 ghciUnblock $ do -- unblock necessary if we recursed from the
395 -- exception handler above.
397 -- read commands from stdin
401 else fileLoop stdin show_prompt
403 fileLoop stdin show_prompt
407 -- NOTE: We only read .ghci files if they are owned by the current user,
408 -- and aren't world writable. Otherwise, we could be accidentally
409 -- running code planted by a malicious third party.
411 -- Furthermore, We only read ./.ghci if . is owned by the current user
412 -- and isn't writable by anyone else. I think this is sufficient: we
413 -- don't need to check .. and ../.. etc. because "." always refers to
414 -- the same directory while a process is running.
416 checkPerms :: String -> IO Bool
418 #ifdef mingw32_HOST_OS
421 Util.handle (\_ -> return False) $ do
422 st <- getFileStatus name
424 if fileOwner st /= me then do
425 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
428 let mode = fileMode st
429 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
430 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
432 putStrLn $ "*** WARNING: " ++ name ++
433 " is writable by someone else, IGNORING!"
438 fileLoop :: Handle -> Bool -> GHCi ()
439 fileLoop hdl show_prompt = do
440 when show_prompt $ do
443 l <- io (IO.try (hGetLine hdl))
445 Left e | isEOFError e -> return ()
446 | InvalidArgument <- etype -> return ()
447 | otherwise -> io (ioError e)
448 where etype = ioeGetErrorType e
449 -- treat InvalidArgument in the same way as EOF:
450 -- this can happen if the user closed stdin, or
451 -- perhaps did getContents which closes stdin at
454 case removeSpaces l of
455 "" -> fileLoop hdl show_prompt
456 l -> do quit <- runCommands l
457 if quit then return () else fileLoop hdl show_prompt
460 session <- getSession
461 (toplevs,exports) <- io (GHC.getContext session)
462 resumes <- io $ GHC.getResumeContext session
468 let ix = GHC.resumeHistoryIx r
470 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
472 let hist = GHC.resumeHistory r !! (ix-1)
473 span <- io $ GHC.getHistorySpan session hist
474 return (brackets (ppr (negate ix) <> char ':'
475 <+> ppr span) <> space)
477 dots | r:rs <- resumes, not (null rs) = text "... "
481 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
482 hsep (map (ppr . GHC.moduleName) exports)
484 deflt_prompt = dots <> context_bit <> modules_bit
486 f ('%':'s':xs) = deflt_prompt <> f xs
487 f ('%':'%':xs) = char '%' <> f xs
488 f (x:xs) = char x <> f xs
492 return (showSDoc (f (prompt st)))
496 readlineLoop :: GHCi ()
498 session <- getSession
499 (mod,imports) <- io (GHC.getContext session)
501 saveSession -- for use by completion
503 mb_span <- getCurrentBreakSpan
505 l <- io (readline prompt `finally` setNonBlockingFD 0)
506 -- readline sometimes puts stdin into blocking mode,
507 -- so we need to put it back for the IO library
512 case removeSpaces l of
516 quit <- runCommands l
517 if quit then return () else readlineLoop
520 runCommands :: String -> GHCi Bool
522 q <- ghciHandle handler (doCommand cmd)
523 if q then return True else runNext
529 c:cs -> do setGHCiState st{ cmdqueue = cs }
532 doCommand (':' : cmd) = specialCommand cmd
533 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
536 enqueueCommands :: [String] -> GHCi ()
537 enqueueCommands cmds = do
539 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
542 -- This version is for the GHC command-line option -e. The only difference
543 -- from runCommand is that it catches the ExitException exception and
544 -- exits, rather than printing out the exception.
545 runCommandEval c = ghciHandle handleEval (doCommand c)
547 handleEval (ExitException code) = io (exitWith code)
548 handleEval e = do handler e
549 io (exitWith (ExitFailure 1))
551 doCommand (':' : command) = specialCommand command
553 = do r <- runStmt stmt GHC.RunToCompletion
555 False -> io (exitWith (ExitFailure 1))
556 -- failure to run the command causes exit(1) for ghc -e.
559 runStmt :: String -> SingleStep -> GHCi Bool
561 | null (filter (not.isSpace) stmt) = return False
562 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
564 = do st <- getGHCiState
565 session <- getSession
566 result <- io $ withProgName (progname st) $ withArgs (args st) $
567 GHC.runStmt session stmt step
571 afterRunStmt :: GHC.RunResult -> GHCi Bool
572 -- False <=> the statement failed to compile
573 afterRunStmt (GHC.RunException e) = throw e
574 afterRunStmt run_result = do
575 session <- getSession
577 GHC.RunOk names -> do
578 show_types <- isOptionSet ShowType
579 when show_types $ mapM_ (showTypeOfName session) names
580 GHC.RunBreak _ names mb_info -> do
581 resumes <- io $ GHC.getResumeContext session
582 printForUser $ ptext SLIT("Stopped at") <+>
583 ppr (GHC.resumeSpan (head resumes))
584 mapM_ (showTypeOfName session) names
585 maybe (return ()) runBreakCmd mb_info
586 -- run the command set with ":set stop <cmd>"
588 enqueueCommands [stop st]
593 io installSignalHandlers
594 b <- isOptionSet RevertCAFs
595 io (when b revertCAFs)
597 return (case run_result of GHC.RunOk _ -> True; _ -> False)
599 runBreakCmd :: GHC.BreakInfo -> GHCi ()
600 runBreakCmd info = do
601 let mod = GHC.breakInfo_module info
602 nm = GHC.breakInfo_number info
604 case [ loc | (i,loc) <- breaks st,
605 breakModule loc == mod, breakTick loc == nm ] of
607 loc:_ | null cmd -> return ()
608 | otherwise -> do enqueueCommands [cmd]; return ()
609 where cmd = onBreakCmd loc
611 showTypeOfName :: Session -> Name -> GHCi ()
612 showTypeOfName session n
613 = do maybe_tything <- io (GHC.lookupName session n)
614 case maybe_tything of
616 Just thing -> showTyThing thing
618 specialCommand :: String -> GHCi Bool
619 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
620 specialCommand str = do
621 let (cmd,rest) = break isSpace str
622 maybe_cmd <- io (lookupCommand cmd)
624 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
625 ++ shortHelpText) >> return False)
626 Just (_,f,_,_) -> f (dropWhile isSpace rest)
628 lookupCommand :: String -> IO (Maybe Command)
629 lookupCommand str = do
630 cmds <- readIORef commands
631 -- look for exact match first, then the first prefix match
632 case [ c | c <- cmds, str == cmdName c ] of
633 c:_ -> return (Just c)
634 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
636 c:_ -> return (Just c)
639 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
640 getCurrentBreakSpan = do
641 session <- getSession
642 resumes <- io $ GHC.getResumeContext session
646 let ix = GHC.resumeHistoryIx r
648 then return (Just (GHC.resumeSpan r))
650 let hist = GHC.resumeHistory r !! (ix-1)
651 span <- io $ GHC.getHistorySpan session hist
654 -----------------------------------------------------------------------------
657 noArgs :: GHCi () -> String -> GHCi ()
659 noArgs m _ = io $ putStrLn "This command takes no arguments"
661 help :: String -> GHCi ()
662 help _ = io (putStr helpText)
664 info :: String -> GHCi ()
665 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
666 info s = do { let names = words s
667 ; session <- getSession
668 ; dflags <- getDynFlags
669 ; let exts = dopt Opt_GlasgowExts dflags
670 ; mapM_ (infoThing exts session) names }
672 infoThing exts session str = io $ do
673 names <- GHC.parseName session str
674 let filtered = filterOutChildren names
675 mb_stuffs <- mapM (GHC.getInfo session) filtered
676 unqual <- GHC.getPrintUnqual session
677 putStrLn (showSDocForUser unqual $
678 vcat (intersperse (text "") $
679 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
681 -- Filter out names whose parent is also there Good
682 -- example is '[]', which is both a type and data
683 -- constructor in the same type
684 filterOutChildren :: [Name] -> [Name]
685 filterOutChildren names = filter (not . parent_is_there) names
686 where parent_is_there n
687 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
691 pprInfo exts (thing, fixity, insts)
692 = pprTyThingInContextLoc exts thing
693 $$ show_fixity fixity
694 $$ vcat (map GHC.pprInstance insts)
697 | fix == GHC.defaultFixity = empty
698 | otherwise = ppr fix <+> ppr (GHC.getName thing)
700 runMain :: String -> GHCi ()
702 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
703 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
705 addModule :: [FilePath] -> GHCi ()
707 io (revertCAFs) -- always revert CAFs on load/add.
708 files <- mapM expandPath files
709 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
710 session <- getSession
711 io (mapM_ (GHC.addTarget session) targets)
712 ok <- io (GHC.load session LoadAllTargets)
715 changeDirectory :: String -> GHCi ()
716 changeDirectory dir = do
717 session <- getSession
718 graph <- io (GHC.getModuleGraph session)
719 when (not (null graph)) $
720 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
721 io (GHC.setTargets session [])
722 io (GHC.load session LoadAllTargets)
723 setContextAfterLoad session []
724 io (GHC.workingDirectoryChanged session)
725 dir <- expandPath dir
726 io (setCurrentDirectory dir)
728 editFile :: String -> GHCi ()
730 do file <- if null str then chooseEditFile else return str
734 $ throwDyn (CmdLineError "editor not set, use :set editor")
735 io $ system (cmd ++ ' ':file)
738 -- The user didn't specify a file so we pick one for them.
739 -- Our strategy is to pick the first module that failed to load,
740 -- or otherwise the first target.
742 -- XXX: Can we figure out what happened if the depndecy analysis fails
743 -- (e.g., because the porgrammeer mistyped the name of a module)?
744 -- XXX: Can we figure out the location of an error to pass to the editor?
745 -- XXX: if we could figure out the list of errors that occured during the
746 -- last load/reaload, then we could start the editor focused on the first
748 chooseEditFile :: GHCi String
750 do session <- getSession
751 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
753 graph <- io (GHC.getModuleGraph session)
754 failed_graph <- filterM hasFailed graph
755 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
757 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
760 case pick (order failed_graph) of
761 Just file -> return file
763 do targets <- io (GHC.getTargets session)
764 case msum (map fromTarget targets) of
765 Just file -> return file
766 Nothing -> throwDyn (CmdLineError "No files to edit.")
768 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
769 fromTarget _ = Nothing -- when would we get a module target?
771 defineMacro :: String -> GHCi ()
773 let (macro_name, definition) = break isSpace s
774 cmds <- io (readIORef commands)
776 then throwDyn (CmdLineError "invalid macro name")
778 if (macro_name `elem` map cmdName cmds)
779 then throwDyn (CmdLineError
780 ("command '" ++ macro_name ++ "' is already defined"))
783 -- give the expression a type signature, so we can be sure we're getting
784 -- something of the right type.
785 let new_expr = '(' : definition ++ ") :: String -> IO String"
787 -- compile the expression
789 maybe_hv <- io (GHC.compileExpr cms new_expr)
792 Just hv -> io (writeIORef commands --
793 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
795 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
797 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
798 enqueueCommands (lines str)
801 undefineMacro :: String -> GHCi ()
802 undefineMacro macro_name = do
803 cmds <- io (readIORef commands)
804 if (macro_name `elem` map cmdName builtin_commands)
805 then throwDyn (CmdLineError
806 ("command '" ++ macro_name ++ "' cannot be undefined"))
808 if (macro_name `notElem` map cmdName cmds)
809 then throwDyn (CmdLineError
810 ("command '" ++ macro_name ++ "' not defined"))
812 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
814 cmdCmd :: String -> GHCi ()
816 let expr = '(' : str ++ ") :: IO String"
817 session <- getSession
818 maybe_hv <- io (GHC.compileExpr session expr)
822 cmds <- io $ (unsafeCoerce# hv :: IO String)
823 enqueueCommands (lines cmds)
826 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
827 loadModule fs = timeIt (loadModule' fs)
829 loadModule_ :: [FilePath] -> GHCi ()
830 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
832 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
833 loadModule' files = do
834 session <- getSession
837 discardActiveBreakPoints
838 io (GHC.setTargets session [])
839 io (GHC.load session LoadAllTargets)
842 let (filenames, phases) = unzip files
843 exp_filenames <- mapM expandPath filenames
844 let files' = zip exp_filenames phases
845 targets <- io (mapM (uncurry GHC.guessTarget) files')
847 -- NOTE: we used to do the dependency anal first, so that if it
848 -- fails we didn't throw away the current set of modules. This would
849 -- require some re-working of the GHC interface, so we'll leave it
850 -- as a ToDo for now.
852 io (GHC.setTargets session targets)
853 doLoad session LoadAllTargets
855 checkModule :: String -> GHCi ()
857 let modl = GHC.mkModuleName m
858 session <- getSession
859 result <- io (GHC.checkModule session modl)
861 Nothing -> io $ putStrLn "Nothing"
862 Just r -> io $ putStrLn (showSDoc (
863 case GHC.checkedModuleInfo r of
864 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
866 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
868 (text "global names: " <+> ppr global) $$
869 (text "local names: " <+> ppr local)
871 afterLoad (successIf (isJust result)) session
873 reloadModule :: String -> GHCi ()
875 io (revertCAFs) -- always revert CAFs on reload.
876 discardActiveBreakPoints
877 session <- getSession
878 doLoad session $ if null m then LoadAllTargets
879 else LoadUpTo (GHC.mkModuleName m)
882 doLoad session howmuch = do
883 -- turn off breakpoints before we load: we can't turn them off later, because
884 -- the ModBreaks will have gone away.
885 discardActiveBreakPoints
886 ok <- io (GHC.load session howmuch)
890 afterLoad ok session = do
891 io (revertCAFs) -- always revert CAFs on load.
893 graph <- io (GHC.getModuleGraph session)
894 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
895 setContextAfterLoad session graph'
896 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
898 setContextAfterLoad session [] = do
899 prel_mod <- getPrelude
900 io (GHC.setContext session [] [prel_mod])
901 setContextAfterLoad session ms = do
902 -- load a target if one is available, otherwise load the topmost module.
903 targets <- io (GHC.getTargets session)
904 case [ m | Just m <- map (findTarget ms) targets ] of
906 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
907 load_this (last graph')
912 = case filter (`matches` t) ms of
916 summary `matches` Target (TargetModule m) _
917 = GHC.ms_mod_name summary == m
918 summary `matches` Target (TargetFile f _) _
919 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
920 summary `matches` target
923 load_this summary | m <- GHC.ms_mod summary = do
924 b <- io (GHC.moduleIsInterpreted session m)
925 if b then io (GHC.setContext session [m] [])
927 prel_mod <- getPrelude
928 io (GHC.setContext session [] [prel_mod,m])
931 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
932 modulesLoadedMsg ok mods = do
933 dflags <- getDynFlags
934 when (verbosity dflags > 0) $ do
936 | null mods = text "none."
938 punctuate comma (map ppr mods)) <> text "."
941 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
943 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
946 typeOfExpr :: String -> GHCi ()
948 = do cms <- getSession
949 maybe_ty <- io (GHC.exprType cms str)
952 Just ty -> do ty' <- cleanType ty
953 printForUser $ text str <> text " :: " <> ppr ty'
955 kindOfType :: String -> GHCi ()
957 = do cms <- getSession
958 maybe_ty <- io (GHC.typeKind cms str)
961 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
963 quit :: String -> GHCi Bool
966 shellEscape :: String -> GHCi Bool
967 shellEscape str = io (system str >> return False)
969 -----------------------------------------------------------------------------
970 -- Browsing a module's contents
972 browseCmd :: String -> GHCi ()
975 ['*':m] | looksLikeModuleName m -> browseModule m False
976 [m] | looksLikeModuleName m -> browseModule m True
977 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
979 browseModule m exports_only = do
981 modl <- if exports_only then lookupModule m
982 else wantInterpretedModule m
984 -- Temporarily set the context to the module we're interested in,
985 -- just so we can get an appropriate PrintUnqualified
986 (as,bs) <- io (GHC.getContext s)
987 prel_mod <- getPrelude
988 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
989 else GHC.setContext s [modl] [])
990 unqual <- io (GHC.getPrintUnqual s)
991 io (GHC.setContext s as bs)
993 mb_mod_info <- io $ GHC.getModuleInfo s modl
995 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
998 | exports_only = GHC.modInfoExports mod_info
999 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1001 filtered = filterOutChildren names
1003 things <- io $ mapM (GHC.lookupName s) filtered
1005 dflags <- getDynFlags
1006 let exts = dopt Opt_GlasgowExts dflags
1007 io (putStrLn (showSDocForUser unqual (
1008 vcat (map (pprTyThingInContext exts) (catMaybes things))
1010 -- ToDo: modInfoInstances currently throws an exception for
1011 -- package modules. When it works, we can do this:
1012 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1014 -----------------------------------------------------------------------------
1015 -- Setting the module context
1018 | all sensible mods = fn mods
1019 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1021 (fn, mods) = case str of
1022 '+':stuff -> (addToContext, words stuff)
1023 '-':stuff -> (removeFromContext, words stuff)
1024 stuff -> (newContext, words stuff)
1026 sensible ('*':m) = looksLikeModuleName m
1027 sensible m = looksLikeModuleName m
1029 separate :: Session -> [String] -> [Module] -> [Module]
1030 -> GHCi ([Module],[Module])
1031 separate session [] as bs = return (as,bs)
1032 separate session (('*':str):ms) as bs = do
1033 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1034 b <- io $ GHC.moduleIsInterpreted session m
1035 if b then separate session ms (m:as) bs
1036 else throwDyn (CmdLineError ("module '"
1037 ++ GHC.moduleNameString (GHC.moduleName m)
1038 ++ "' is not interpreted"))
1039 separate session (str:ms) as bs = do
1040 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1041 separate session ms as (m:bs)
1043 newContext :: [String] -> GHCi ()
1044 newContext strs = do
1046 (as,bs) <- separate s strs [] []
1047 prel_mod <- getPrelude
1048 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1049 io $ GHC.setContext s as bs'
1052 addToContext :: [String] -> GHCi ()
1053 addToContext strs = do
1055 (as,bs) <- io $ GHC.getContext s
1057 (new_as,new_bs) <- separate s strs [] []
1059 let as_to_add = new_as \\ (as ++ bs)
1060 bs_to_add = new_bs \\ (as ++ bs)
1062 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1065 removeFromContext :: [String] -> GHCi ()
1066 removeFromContext strs = do
1068 (as,bs) <- io $ GHC.getContext s
1070 (as_to_remove,bs_to_remove) <- separate s strs [] []
1072 let as' = as \\ (as_to_remove ++ bs_to_remove)
1073 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1075 io $ GHC.setContext s as' bs'
1077 ----------------------------------------------------------------------------
1080 -- set options in the interpreter. Syntax is exactly the same as the
1081 -- ghc command line, except that certain options aren't available (-C,
1084 -- This is pretty fragile: most options won't work as expected. ToDo:
1085 -- figure out which ones & disallow them.
1087 setCmd :: String -> GHCi ()
1089 = do st <- getGHCiState
1090 let opts = options st
1091 io $ putStrLn (showSDoc (
1092 text "options currently set: " <>
1095 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1098 = case toArgs str of
1099 ("args":args) -> setArgs args
1100 ("prog":prog) -> setProg prog
1101 ("prompt":prompt) -> setPrompt (after 6)
1102 ("editor":cmd) -> setEditor (after 6)
1103 ("stop":cmd) -> setStop (after 4)
1104 wds -> setOptions wds
1105 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1109 setGHCiState st{ args = args }
1113 setGHCiState st{ progname = prog }
1115 io (hPutStrLn stderr "syntax: :set prog <progname>")
1119 setGHCiState st{ editor = cmd }
1121 setStop str@(c:_) | isDigit c
1122 = do let (nm_str,rest) = break (not.isDigit) str
1125 let old_breaks = breaks st
1126 if all ((/= nm) . fst) old_breaks
1127 then printForUser (text "Breakpoint" <+> ppr nm <+>
1128 text "does not exist")
1130 let new_breaks = map fn old_breaks
1131 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1132 | otherwise = (i,loc)
1133 setGHCiState st{ breaks = new_breaks }
1136 setGHCiState st{ stop = cmd }
1138 setPrompt value = do
1141 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1142 else setGHCiState st{ prompt = remQuotes value }
1144 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1148 do -- first, deal with the GHCi opts (+s, +t, etc.)
1149 let (plus_opts, minus_opts) = partition isPlus wds
1150 mapM_ setOpt plus_opts
1151 -- then, dynamic flags
1152 newDynFlags minus_opts
1154 newDynFlags minus_opts = do
1155 dflags <- getDynFlags
1156 let pkg_flags = packageFlags dflags
1157 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1159 if (not (null leftovers))
1160 then throwDyn (CmdLineError ("unrecognised flags: " ++
1164 new_pkgs <- setDynFlags dflags'
1166 -- if the package flags changed, we should reset the context
1167 -- and link the new packages.
1168 dflags <- getDynFlags
1169 when (packageFlags dflags /= pkg_flags) $ do
1170 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1171 session <- getSession
1172 io (GHC.setTargets session [])
1173 io (GHC.load session LoadAllTargets)
1174 io (linkPackages dflags new_pkgs)
1175 setContextAfterLoad session []
1179 unsetOptions :: String -> GHCi ()
1181 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1182 let opts = words str
1183 (minus_opts, rest1) = partition isMinus opts
1184 (plus_opts, rest2) = partition isPlus rest1
1186 if (not (null rest2))
1187 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1190 mapM_ unsetOpt plus_opts
1192 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1193 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1195 no_flags <- mapM no_flag minus_opts
1196 newDynFlags no_flags
1198 isMinus ('-':s) = True
1201 isPlus ('+':s) = True
1205 = case strToGHCiOpt str of
1206 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1207 Just o -> setOption o
1210 = case strToGHCiOpt str of
1211 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1212 Just o -> unsetOption o
1214 strToGHCiOpt :: String -> (Maybe GHCiOption)
1215 strToGHCiOpt "s" = Just ShowTiming
1216 strToGHCiOpt "t" = Just ShowType
1217 strToGHCiOpt "r" = Just RevertCAFs
1218 strToGHCiOpt _ = Nothing
1220 optToStr :: GHCiOption -> String
1221 optToStr ShowTiming = "s"
1222 optToStr ShowType = "t"
1223 optToStr RevertCAFs = "r"
1225 -- ---------------------------------------------------------------------------
1231 ["args"] -> io $ putStrLn (show (args st))
1232 ["prog"] -> io $ putStrLn (show (progname st))
1233 ["prompt"] -> io $ putStrLn (show (prompt st))
1234 ["editor"] -> io $ putStrLn (show (editor st))
1235 ["stop"] -> io $ putStrLn (show (stop st))
1236 ["modules" ] -> showModules
1237 ["bindings"] -> showBindings
1238 ["linker"] -> io showLinkerState
1239 ["breaks"] -> showBkptTable
1240 ["context"] -> showContext
1241 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1244 session <- getSession
1245 let show_one ms = do m <- io (GHC.showModule session ms)
1247 graph <- io (GHC.getModuleGraph session)
1248 mapM_ show_one graph
1252 unqual <- io (GHC.getPrintUnqual s)
1253 bindings <- io (GHC.getBindings s)
1254 mapM_ showTyThing bindings
1257 showTyThing (AnId id) = do
1258 ty' <- cleanType (GHC.idType id)
1259 printForUser $ ppr id <> text " :: " <> ppr ty'
1260 showTyThing _ = return ()
1262 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1263 cleanType :: Type -> GHCi Type
1265 dflags <- getDynFlags
1266 if dopt Opt_GlasgowExts dflags
1268 else return $! GHC.dropForAlls ty
1270 showBkptTable :: GHCi ()
1273 printForUser $ prettyLocations (breaks st)
1275 showContext :: GHCi ()
1277 session <- getSession
1278 resumes <- io $ GHC.getResumeContext session
1279 printForUser $ vcat (map pp_resume (reverse resumes))
1282 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1283 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1286 -- -----------------------------------------------------------------------------
1289 completeNone :: String -> IO [String]
1290 completeNone w = return []
1293 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1294 completeWord w start end = do
1295 line <- Readline.getLineBuffer
1297 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1299 | Just c <- is_cmd line -> do
1300 maybe_cmd <- lookupCommand c
1301 let (n,w') = selectWord (words' 0 line)
1303 Nothing -> return Nothing
1304 Just (_,_,False,complete) -> wrapCompleter complete w
1305 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1306 return (map (drop n) rets)
1307 in wrapCompleter complete' w'
1309 --printf "complete %s, start = %d, end = %d\n" w start end
1310 wrapCompleter completeIdentifier w
1311 where words' _ [] = []
1312 words' n str = let (w,r) = break isSpace str
1313 (s,r') = span isSpace r
1314 in (n,w):words' (n+length w+length s) r'
1315 -- In a Haskell expression we want to parse 'a-b' as three words
1316 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1317 -- only be a single word.
1318 selectWord [] = (0,w)
1319 selectWord ((offset,x):xs)
1320 | offset+length x >= start = (start-offset,take (end-offset) x)
1321 | otherwise = selectWord xs
1324 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1325 | otherwise = Nothing
1328 cmds <- readIORef commands
1329 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1331 completeMacro w = do
1332 cmds <- readIORef commands
1333 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1334 return (filter (w `isPrefixOf`) cmds')
1336 completeIdentifier w = do
1338 rdrs <- GHC.getRdrNamesInScope s
1339 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1341 completeModule w = do
1343 dflags <- GHC.getSessionDynFlags s
1344 let pkg_mods = allExposedModules dflags
1345 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1347 completeHomeModule w = do
1349 g <- GHC.getModuleGraph s
1350 let home_mods = map GHC.ms_mod_name g
1351 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1353 completeSetOptions w = do
1354 return (filter (w `isPrefixOf`) options)
1355 where options = "args":"prog":allFlags
1357 completeFilename = Readline.filenameCompletionFunction
1359 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1361 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1362 unionComplete f1 f2 w = do
1367 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1368 wrapCompleter fun w = do
1371 [] -> return Nothing
1372 [x] -> return (Just (x,[]))
1373 xs -> case getCommonPrefix xs of
1374 "" -> return (Just ("",xs))
1375 pref -> return (Just (pref,xs))
1377 getCommonPrefix :: [String] -> String
1378 getCommonPrefix [] = ""
1379 getCommonPrefix (s:ss) = foldl common s ss
1380 where common s "" = ""
1382 common (c:cs) (d:ds)
1383 | c == d = c : common cs ds
1386 allExposedModules :: DynFlags -> [ModuleName]
1387 allExposedModules dflags
1388 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1390 pkg_db = pkgIdMap (pkgState dflags)
1392 completeCmd = completeNone
1393 completeMacro = completeNone
1394 completeIdentifier = completeNone
1395 completeModule = completeNone
1396 completeHomeModule = completeNone
1397 completeSetOptions = completeNone
1398 completeFilename = completeNone
1399 completeHomeModuleOrFile=completeNone
1400 completeBkpt = completeNone
1403 -- ---------------------------------------------------------------------------
1404 -- User code exception handling
1406 -- This is the exception handler for exceptions generated by the
1407 -- user's code and exceptions coming from children sessions;
1408 -- it normally just prints out the exception. The
1409 -- handler must be recursive, in case showing the exception causes
1410 -- more exceptions to be raised.
1412 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1413 -- raising another exception. We therefore don't put the recursive
1414 -- handler arond the flushing operation, so if stderr is closed
1415 -- GHCi will just die gracefully rather than going into an infinite loop.
1416 handler :: Exception -> GHCi Bool
1418 handler exception = do
1420 io installSignalHandlers
1421 ghciHandle handler (showException exception >> return False)
1423 showException (DynException dyn) =
1424 case fromDynamic dyn of
1425 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1426 Just Interrupted -> io (putStrLn "Interrupted.")
1427 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1428 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1429 Just other_ghc_ex -> io (print other_ghc_ex)
1431 showException other_exception
1432 = io (putStrLn ("*** Exception: " ++ show other_exception))
1434 -----------------------------------------------------------------------------
1435 -- recursive exception handlers
1437 -- Don't forget to unblock async exceptions in the handler, or if we're
1438 -- in an exception loop (eg. let a = error a in a) the ^C exception
1439 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1441 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1442 ghciHandle h (GHCi m) = GHCi $ \s ->
1443 Exception.catch (m s)
1444 (\e -> unGHCi (ghciUnblock (h e)) s)
1446 ghciUnblock :: GHCi a -> GHCi a
1447 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1450 -- ----------------------------------------------------------------------------
1453 expandPath :: String -> GHCi String
1455 case dropWhile isSpace path of
1457 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1458 return (tilde ++ '/':d)
1462 wantInterpretedModule :: String -> GHCi Module
1463 wantInterpretedModule str = do
1464 session <- getSession
1465 modl <- lookupModule str
1466 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1467 when (not is_interpreted) $
1468 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1471 wantNameFromInterpretedModule noCanDo str and_then = do
1472 session <- getSession
1473 names <- io $ GHC.parseName session str
1477 let modl = GHC.nameModule n
1478 if not (GHC.isExternalName n)
1479 then noCanDo n $ ppr n <>
1480 text " is not defined in an interpreted module"
1482 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1483 if not is_interpreted
1484 then noCanDo n $ text "module " <> ppr modl <>
1485 text " is not interpreted"
1488 -- ----------------------------------------------------------------------------
1489 -- Windows console setup
1491 setUpConsole :: IO ()
1493 #ifdef mingw32_HOST_OS
1494 -- On Windows we need to set a known code page, otherwise the characters
1495 -- we read from the console will be be in some strange encoding, and
1496 -- similarly for characters we write to the console.
1498 -- At the moment, GHCi pretends all input is Latin-1. In the
1499 -- future we should support UTF-8, but for now we set the code pages
1502 -- It seems you have to set the font in the console window to
1503 -- a Unicode font in order for output to work properly,
1504 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1505 -- (see MSDN for SetConsoleOutputCP()).
1507 setConsoleCP 28591 -- ISO Latin-1
1508 setConsoleOutputCP 28591 -- ISO Latin-1
1512 -- -----------------------------------------------------------------------------
1513 -- commands for debugger
1515 sprintCmd = pprintCommand False False
1516 printCmd = pprintCommand True False
1517 forceCmd = pprintCommand False True
1519 pprintCommand bind force str = do
1520 session <- getSession
1521 io $ pprintClosureCommand session bind force str
1523 stepCmd :: String -> GHCi ()
1524 stepCmd [] = doContinue GHC.SingleStep
1525 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1527 traceCmd :: String -> GHCi ()
1528 traceCmd [] = doContinue GHC.RunAndLogSteps
1529 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1531 continueCmd :: String -> GHCi ()
1532 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1534 doContinue :: SingleStep -> GHCi ()
1535 doContinue step = do
1536 session <- getSession
1537 runResult <- io $ GHC.resume session step
1538 afterRunStmt runResult
1541 abandonCmd :: String -> GHCi ()
1542 abandonCmd = noArgs $ do
1544 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1545 when (not b) $ io $ putStrLn "There is no computation running."
1548 deleteCmd :: String -> GHCi ()
1549 deleteCmd argLine = do
1550 deleteSwitch $ words argLine
1552 deleteSwitch :: [String] -> GHCi ()
1554 io $ putStrLn "The delete command requires at least one argument."
1555 -- delete all break points
1556 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1557 deleteSwitch idents = do
1558 mapM_ deleteOneBreak idents
1560 deleteOneBreak :: String -> GHCi ()
1562 | all isDigit str = deleteBreak (read str)
1563 | otherwise = return ()
1565 historyCmd :: String -> GHCi ()
1567 | null arg = history 20
1568 | all isDigit arg = history (read arg)
1569 | otherwise = io $ putStrLn "Syntax: :history [num]"
1573 resumes <- io $ GHC.getResumeContext s
1575 [] -> io $ putStrLn "Not stopped at a breakpoint"
1577 let hist = GHC.resumeHistory r
1578 (took,rest) = splitAt num hist
1579 spans <- mapM (io . GHC.getHistorySpan s) took
1580 let nums = map (printf "-%-3d:") [(1::Int)..]
1581 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1582 io $ putStrLn $ if null rest then "<end of history>" else "..."
1584 backCmd :: String -> GHCi ()
1585 backCmd = noArgs $ do
1587 (names, ix, span) <- io $ GHC.back s
1588 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1589 mapM_ (showTypeOfName s) names
1590 -- run the command set with ":set stop <cmd>"
1592 enqueueCommands [stop st]
1594 forwardCmd :: String -> GHCi ()
1595 forwardCmd = noArgs $ do
1597 (names, ix, span) <- io $ GHC.forward s
1598 printForUser $ (if (ix == 0)
1599 then ptext SLIT("Stopped at")
1600 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1601 mapM_ (showTypeOfName s) names
1602 -- run the command set with ":set stop <cmd>"
1604 enqueueCommands [stop st]
1606 -- handle the "break" command
1607 breakCmd :: String -> GHCi ()
1608 breakCmd argLine = do
1609 session <- getSession
1610 breakSwitch session $ words argLine
1612 breakSwitch :: Session -> [String] -> GHCi ()
1613 breakSwitch _session [] = do
1614 io $ putStrLn "The break command requires at least one argument."
1615 breakSwitch session args@(arg1:rest)
1616 | looksLikeModuleName arg1 = do
1617 mod <- wantInterpretedModule arg1
1618 breakByModule session mod rest
1619 | all isDigit arg1 = do
1620 (toplevel, _) <- io $ GHC.getContext session
1622 (mod : _) -> breakByModuleLine mod (read arg1) rest
1624 io $ putStrLn "Cannot find default module for breakpoint."
1625 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1626 | otherwise = do -- try parsing it as an identifier
1627 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1628 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1629 if GHC.isGoodSrcLoc loc
1630 then findBreakAndSet (GHC.nameModule name) $
1631 findBreakByCoord (Just (GHC.srcLocFile loc))
1632 (GHC.srcLocLine loc,
1634 else noCanDo name $ text "can't find its location: " <> ppr loc
1636 noCanDo n why = printForUser $
1637 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1639 breakByModule :: Session -> Module -> [String] -> GHCi ()
1640 breakByModule session mod args@(arg1:rest)
1641 | all isDigit arg1 = do -- looks like a line number
1642 breakByModuleLine mod (read arg1) rest
1643 | otherwise = io $ putStrLn "Invalid arguments to :break"
1645 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1646 breakByModuleLine mod line args
1647 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1648 | [col] <- args, all isDigit col =
1649 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1650 | otherwise = io $ putStrLn "Invalid arguments to :break"
1652 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1653 findBreakAndSet mod lookupTickTree = do
1654 tickArray <- getTickArray mod
1655 (breakArray, _) <- getModBreak mod
1656 case lookupTickTree tickArray of
1657 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1658 Just (tick, span) -> do
1659 success <- io $ setBreakFlag True breakArray tick
1660 session <- getSession
1664 recordBreak $ BreakLocation
1671 text "Breakpoint " <> ppr nm <>
1673 then text " was already set at " <> ppr span
1674 else text " activated at " <> ppr span
1676 printForUser $ text "Breakpoint could not be activated at"
1679 -- When a line number is specified, the current policy for choosing
1680 -- the best breakpoint is this:
1681 -- - the leftmost complete subexpression on the specified line, or
1682 -- - the leftmost subexpression starting on the specified line, or
1683 -- - the rightmost subexpression enclosing the specified line
1685 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1686 findBreakByLine line arr
1687 | not (inRange (bounds arr) line) = Nothing
1689 listToMaybe (sortBy leftmost_largest complete) `mplus`
1690 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1691 listToMaybe (sortBy rightmost ticks)
1695 starts_here = [ tick | tick@(nm,span) <- ticks,
1696 GHC.srcSpanStartLine span == line ]
1698 (complete,incomplete) = partition ends_here starts_here
1699 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1701 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1702 -> Maybe (BreakIndex,SrcSpan)
1703 findBreakByCoord mb_file (line, col) arr
1704 | not (inRange (bounds arr) line) = Nothing
1706 listToMaybe (sortBy rightmost contains) `mplus`
1707 listToMaybe (sortBy leftmost_smallest after_here)
1711 -- the ticks that span this coordinate
1712 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1713 is_correct_file span ]
1715 is_correct_file span
1716 | Just f <- mb_file = GHC.srcSpanFile span == f
1719 after_here = [ tick | tick@(nm,span) <- ticks,
1720 GHC.srcSpanStartLine span == line,
1721 GHC.srcSpanStartCol span >= col ]
1724 leftmost_smallest (_,a) (_,b) = a `compare` b
1725 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1727 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1728 rightmost (_,a) (_,b) = b `compare` a
1730 spans :: SrcSpan -> (Int,Int) -> Bool
1731 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1732 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1734 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1735 -- of carets under the active expression instead. The Windows console
1736 -- doesn't support ANSI escape sequences, and most Unix terminals
1737 -- (including xterm) do, so this is a reasonable guess until we have a
1738 -- proper termcap/terminfo library.
1739 #if !defined(mingw32_TARGET_OS)
1745 start_bold = BS.pack "\ESC[1m"
1746 end_bold = BS.pack "\ESC[0m"
1748 listCmd :: String -> GHCi ()
1750 mb_span <- getCurrentBreakSpan
1752 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1753 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1754 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1755 listCmd str = list2 (words str)
1757 list2 [arg] | all isDigit arg = do
1758 session <- getSession
1759 (toplevel, _) <- io $ GHC.getContext session
1761 [] -> io $ putStrLn "No module to list"
1762 (mod : _) -> listModuleLine mod (read arg)
1763 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1764 mod <- wantInterpretedModule arg1
1765 listModuleLine mod (read arg2)
1767 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1768 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1769 if GHC.isGoodSrcLoc loc
1771 tickArray <- getTickArray (GHC.nameModule name)
1772 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1773 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1776 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1777 Just (_,span) -> io $ listAround span False
1779 noCanDo name $ text "can't find its location: " <>
1782 noCanDo n why = printForUser $
1783 text "cannot list source code for " <> ppr n <> text ": " <> why
1785 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1787 listModuleLine :: Module -> Int -> GHCi ()
1788 listModuleLine modl line = do
1789 session <- getSession
1790 graph <- io (GHC.getModuleGraph session)
1791 let this = filter ((== modl) . GHC.ms_mod) graph
1793 [] -> panic "listModuleLine"
1795 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1796 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1797 io $ listAround (GHC.srcLocSpan loc) False
1799 -- | list a section of a source file around a particular SrcSpan.
1800 -- If the highlight flag is True, also highlight the span using
1801 -- start_bold/end_bold.
1802 listAround span do_highlight = do
1804 contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1806 lines = BS.split '\n' contents
1807 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1808 drop (line1 - 1 - pad_before) $ lines
1809 fst_line = max 1 (line1 - pad_before)
1810 line_nos = [ fst_line .. ]
1812 highlighted | do_highlight = zipWith highlight line_nos these_lines
1813 | otherwise = these_lines
1815 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1816 prefixed = zipWith BS.append bs_line_nos highlighted
1818 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1820 file = GHC.srcSpanFile span
1821 line1 = GHC.srcSpanStartLine span
1822 col1 = GHC.srcSpanStartCol span
1823 line2 = GHC.srcSpanEndLine span
1824 col2 = GHC.srcSpanEndCol span
1826 pad_before | line1 == 1 = 0
1830 highlight | do_bold = highlight_bold
1831 | otherwise = highlight_carets
1833 highlight_bold no line
1834 | no == line1 && no == line2
1835 = let (a,r) = BS.splitAt col1 line
1836 (b,c) = BS.splitAt (col2-col1) r
1838 BS.concat [a,start_bold,b,end_bold,c]
1840 = let (a,b) = BS.splitAt col1 line in
1841 BS.concat [a, start_bold, b]
1843 = let (a,b) = BS.splitAt col2 line in
1844 BS.concat [a, end_bold, b]
1847 highlight_carets no line
1848 | no == line1 && no == line2
1849 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1850 BS.replicate (col2-col1) '^']
1852 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1853 BS.replicate (BS.length line-col1) '^']
1855 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1858 indent = BS.pack " "
1859 nl = BS.singleton '\n'
1861 -- --------------------------------------------------------------------------
1864 getTickArray :: Module -> GHCi TickArray
1865 getTickArray modl = do
1867 let arrmap = tickarrays st
1868 case lookupModuleEnv arrmap modl of
1869 Just arr -> return arr
1871 (breakArray, ticks) <- getModBreak modl
1872 let arr = mkTickArray (assocs ticks)
1873 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1876 discardTickArrays :: GHCi ()
1877 discardTickArrays = do
1879 setGHCiState st{tickarrays = emptyModuleEnv}
1881 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1883 = accumArray (flip (:)) [] (1, max_line)
1884 [ (line, (nm,span)) | (nm,span) <- ticks,
1885 line <- srcSpanLines span ]
1887 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1888 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1889 GHC.srcSpanEndLine span ]
1891 lookupModule :: String -> GHCi Module
1892 lookupModule modName
1893 = do session <- getSession
1894 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1896 -- don't reset the counter back to zero?
1897 discardActiveBreakPoints :: GHCi ()
1898 discardActiveBreakPoints = do
1900 mapM (turnOffBreak.snd) (breaks st)
1901 setGHCiState $ st { breaks = [] }
1903 deleteBreak :: Int -> GHCi ()
1904 deleteBreak identity = do
1906 let oldLocations = breaks st
1907 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1909 then printForUser (text "Breakpoint" <+> ppr identity <+>
1910 text "does not exist")
1912 mapM (turnOffBreak.snd) this
1913 setGHCiState $ st { breaks = rest }
1915 turnOffBreak loc = do
1916 (arr, _) <- getModBreak (breakModule loc)
1917 io $ setBreakFlag False arr (breakTick loc)
1919 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1920 getModBreak mod = do
1921 session <- getSession
1922 Just mod_info <- io $ GHC.getModuleInfo session mod
1923 let modBreaks = GHC.modInfoModBreaks mod_info
1924 let array = GHC.modBreaks_flags modBreaks
1925 let ticks = GHC.modBreaks_locs modBreaks
1926 return (array, ticks)
1928 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1929 setBreakFlag toggle array index
1930 | toggle = GHC.setBreakOn array index
1931 | otherwise = GHC.setBreakOff array index