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
44 import System.Posix hiding (getEnv)
46 import GHC.ConsoleHandler ( flushConsole )
47 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
48 import qualified System.Win32
52 import Control.Concurrent ( yield ) -- Used in readline loop
53 import System.Console.Readline as Readline
58 import Control.Exception as Exception
59 -- import Control.Concurrent
61 import qualified Data.ByteString.Char8 as BS
65 import System.Environment
66 import System.Exit ( exitWith, ExitCode(..) )
67 import System.Directory
69 import System.IO.Error as IO
73 import Control.Monad as Monad
76 import Foreign.StablePtr ( newStablePtr )
77 import GHC.Exts ( unsafeCoerce# )
78 import GHC.IOBase ( IOErrorType(InvalidArgument) )
80 import Data.IORef ( IORef, readIORef, writeIORef )
82 import System.Posix.Internals ( setNonBlockingFD )
84 -----------------------------------------------------------------------------
88 " / _ \\ /\\ /\\/ __(_)\n"++
89 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
90 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
91 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
93 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
96 GLOBAL_VAR(commands, builtin_commands, [Command])
98 builtin_commands :: [Command]
100 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
101 ("?", keepGoing help, False, completeNone),
102 ("add", keepGoingPaths addModule, False, completeFilename),
103 ("abandon", keepGoing abandonCmd, False, completeNone),
104 ("break", keepGoing breakCmd, False, completeIdentifier),
105 ("back", keepGoing backCmd, False, completeNone),
106 ("browse", keepGoing browseCmd, False, completeModule),
107 ("cd", keepGoing changeDirectory, False, completeFilename),
108 ("check", keepGoing checkModule, False, completeHomeModule),
109 ("continue", keepGoing continueCmd, False, completeNone),
110 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
111 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
112 ("def", keepGoing defineMacro, False, completeIdentifier),
113 ("delete", keepGoing deleteCmd, False, completeNone),
114 ("e", keepGoing editFile, False, completeFilename),
115 ("edit", keepGoing editFile, False, completeFilename),
116 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
117 ("force", keepGoing forceCmd, False, completeIdentifier),
118 ("forward", keepGoing forwardCmd, False, completeNone),
119 ("help", keepGoing help, False, completeNone),
120 ("history", keepGoing historyCmd, False, completeNone),
121 ("info", keepGoing info, False, completeIdentifier),
122 ("kind", keepGoing kindOfType, False, completeIdentifier),
123 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
124 ("list", keepGoing listCmd, False, completeNone),
125 ("module", keepGoing setContext, False, completeModule),
126 ("main", keepGoing runMain, False, completeIdentifier),
127 ("print", keepGoing printCmd, False, completeIdentifier),
128 ("quit", quit, False, completeNone),
129 ("reload", keepGoing reloadModule, False, completeNone),
130 ("set", keepGoing setCmd, True, completeSetOptions),
131 ("show", keepGoing showCmd, False, completeNone),
132 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
133 ("step", keepGoing stepCmd, False, completeIdentifier),
134 ("type", keepGoing typeOfExpr, False, completeIdentifier),
135 ("trace", keepGoing traceCmd, False, completeIdentifier),
136 ("undef", keepGoing undefineMacro, False, completeMacro),
137 ("unset", keepGoing unsetOptions, True, completeSetOptions)
140 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
141 keepGoing a str = a str >> return False
143 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
144 keepGoingPaths a str = a (toArgs str) >> return False
146 shortHelpText = "use :? for help.\n"
149 " Commands available from the prompt:\n" ++
151 " <statement> evaluate/run <statement>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
156 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :edit <file> edit file\n" ++
159 " :edit edit last module\n" ++
160 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
161 " :help, :? display this list of commands\n" ++
162 " :info [<name> ...] display information about the given names\n" ++
163 " :kind <type> show the kind of <type>\n" ++
164 " :load <filename> ... load module(s) and their dependents\n" ++
165 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
166 " :main [<arguments> ...] run the main function with the given arguments\n" ++
167 " :quit exit GHCi\n" ++
168 " :reload reload the current module set\n" ++
169 " :type <expr> show the type of <expr>\n" ++
170 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
171 " :!<command> run the shell command <command>\n" ++
173 " -- Commands for debugging:\n" ++
175 " :abandon at a breakpoint, abandon current computation\n" ++
176 " :back go back in the history (after :trace)\n" ++
177 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
178 " :break <name> set a breakpoint on the specified function\n" ++
179 " :continue resume after a breakpoint\n" ++
180 " :delete <number> delete the specified breakpoint\n" ++
181 " :delete * delete all breakpoints\n" ++
182 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
183 " :forward go forward in the history (after :back)\n" ++
184 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
185 " :print [<name> ...] prints a value without forcing its computation\n" ++
186 " :sprint [<name> ...] simplifed version of :print\n" ++
187 " :step single-step after stopping at a breakpoint\n"++
188 " :step <expr> single-step into <expr>\n"++
189 " :trace trace after stopping at a breakpoint\n"++
190 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
193 " -- Commands for changing settings:\n" ++
195 " :set <option> ... set options\n" ++
196 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
197 " :set prog <progname> set the value returned by System.getProgName\n" ++
198 " :set prompt <prompt> set the prompt used in GHCi\n" ++
199 " :set editor <cmd> set the command used for :edit\n" ++
200 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
201 " :unset <option> ... unset options\n" ++
203 " Options for ':set' and ':unset':\n" ++
205 " +r revert top-level expressions after each evaluation\n" ++
206 " +s print timing/memory stats after each evaluation\n" ++
207 " +t print type after evaluation\n" ++
208 " -<flags> most GHC command line flags can also be set here\n" ++
209 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
211 " -- Commands for displaying information:\n" ++
213 " :show bindings show the current bindings made at the prompt\n" ++
214 " :show breaks show the active breakpoints\n" ++
215 " :show context show the breakpoint context\n" ++
216 " :show modules show the currently loaded modules\n" ++
217 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
224 win <- System.Win32.getWindowsDirectory
225 return (win `joinFileName` "notepad.exe")
230 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
231 interactiveUI session srcs maybe_expr = do
232 -- HACK! If we happen to get into an infinite loop (eg the user
233 -- types 'let x=x in x' at the prompt), then the thread will block
234 -- on a blackhole, and become unreachable during GC. The GC will
235 -- detect that it is unreachable and send it the NonTermination
236 -- exception. However, since the thread is unreachable, everything
237 -- it refers to might be finalized, including the standard Handles.
238 -- This sounds like a bug, but we don't have a good solution right
244 -- Initialise buffering for the *interpreted* I/O system
245 initInterpBuffering session
247 when (isNothing maybe_expr) $ do
248 -- Only for GHCi (not runghc and ghc -e):
249 -- Turn buffering off for the compiled program's stdout/stderr
251 -- Turn buffering off for GHCi's stdout
253 hSetBuffering stdout NoBuffering
254 -- We don't want the cmd line to buffer any input that might be
255 -- intended for the program, so unbuffer stdin.
256 hSetBuffering stdin NoBuffering
258 -- initial context is just the Prelude
259 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
260 GHC.setContext session [] [prel_mod]
264 Readline.setAttemptedCompletionFunction (Just completeWord)
265 --Readline.parseAndBind "set show-all-if-ambiguous 1"
267 let symbols = "!#$%&*+/<=>?@\\^|-~"
268 specials = "(),;[]`{}"
270 word_break_chars = spaces ++ specials ++ symbols
272 Readline.setBasicWordBreakCharacters word_break_chars
273 Readline.setCompleterWordBreakCharacters word_break_chars
276 default_editor <- findEditor
278 startGHCi (runGHCi srcs maybe_expr)
279 GHCiState{ progname = "<interactive>",
283 editor = default_editor,
289 tickarrays = emptyModuleEnv,
294 Readline.resetTerminal Nothing
299 prel_name = GHC.mkModuleName "Prelude"
301 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
302 runGHCi paths maybe_expr = do
303 let read_dot_files = not opt_IgnoreDotGhci
305 when (read_dot_files) $ do
308 exists <- io (doesFileExist file)
310 dir_ok <- io (checkPerms ".")
311 file_ok <- io (checkPerms file)
312 when (dir_ok && file_ok) $ do
313 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
316 Right hdl -> fileLoop hdl False
318 when (read_dot_files) $ do
319 -- Read in $HOME/.ghci
320 either_dir <- io (IO.try (getEnv "HOME"))
324 cwd <- io (getCurrentDirectory)
325 when (dir /= cwd) $ do
326 let file = dir ++ "/.ghci"
327 ok <- io (checkPerms file)
329 either_hdl <- io (IO.try (openFile file ReadMode))
332 Right hdl -> fileLoop hdl False
334 -- Perform a :load for files given on the GHCi command line
335 -- When in -e mode, if the load fails then we want to stop
336 -- immediately rather than going on to evaluate the expression.
337 when (not (null paths)) $ do
338 ok <- ghciHandle (\e -> do showException e; return Failed) $
340 when (isJust maybe_expr && failed ok) $
341 io (exitWith (ExitFailure 1))
343 -- if verbosity is greater than 0, or we are connected to a
344 -- terminal, display the prompt in the interactive loop.
345 is_tty <- io (hIsTerminalDevice stdin)
346 dflags <- getDynFlags
347 let show_prompt = verbosity dflags > 0 || is_tty
352 #if defined(mingw32_HOST_OS)
353 -- The win32 Console API mutates the first character of
354 -- type-ahead when reading from it in a non-buffered manner. Work
355 -- around this by flushing the input buffer of type-ahead characters,
356 -- but only if stdin is available.
357 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
359 Left err | isDoesNotExistError err -> return ()
360 | otherwise -> io (ioError err)
361 Right () -> return ()
363 -- initialise the console if necessary
366 -- enter the interactive loop
367 interactiveLoop is_tty show_prompt
369 -- just evaluate the expression we were given
374 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
377 interactiveLoop is_tty show_prompt =
378 -- Ignore ^C exceptions caught here
379 ghciHandleDyn (\e -> case e of
381 #if defined(mingw32_HOST_OS)
384 interactiveLoop is_tty show_prompt
385 _other -> return ()) $
387 ghciUnblock $ do -- unblock necessary if we recursed from the
388 -- exception handler above.
390 -- read commands from stdin
394 else fileLoop stdin show_prompt
396 fileLoop stdin show_prompt
400 -- NOTE: We only read .ghci files if they are owned by the current user,
401 -- and aren't world writable. Otherwise, we could be accidentally
402 -- running code planted by a malicious third party.
404 -- Furthermore, We only read ./.ghci if . is owned by the current user
405 -- and isn't writable by anyone else. I think this is sufficient: we
406 -- don't need to check .. and ../.. etc. because "." always refers to
407 -- the same directory while a process is running.
409 checkPerms :: String -> IO Bool
411 #ifdef mingw32_HOST_OS
414 Util.handle (\_ -> return False) $ do
415 st <- getFileStatus name
417 if fileOwner st /= me then do
418 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
421 let mode = fileMode st
422 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
423 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
425 putStrLn $ "*** WARNING: " ++ name ++
426 " is writable by someone else, IGNORING!"
431 fileLoop :: Handle -> Bool -> GHCi ()
432 fileLoop hdl show_prompt = do
433 when show_prompt $ do
436 l <- io (IO.try (hGetLine hdl))
438 Left e | isEOFError e -> return ()
439 | InvalidArgument <- etype -> return ()
440 | otherwise -> io (ioError e)
441 where etype = ioeGetErrorType e
442 -- treat InvalidArgument in the same way as EOF:
443 -- this can happen if the user closed stdin, or
444 -- perhaps did getContents which closes stdin at
447 case removeSpaces l of
448 "" -> fileLoop hdl show_prompt
449 l -> do quit <- runCommands l
450 if quit then return () else fileLoop hdl show_prompt
453 session <- getSession
454 (toplevs,exports) <- io (GHC.getContext session)
455 resumes <- io $ GHC.getResumeContext session
461 let ix = GHC.resumeHistoryIx r
463 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
465 let hist = GHC.resumeHistory r !! (ix-1)
466 span <- io $ GHC.getHistorySpan session hist
467 return (brackets (ppr (negate ix) <> char ':'
468 <+> ppr span) <> space)
470 dots | r:rs <- resumes, not (null rs) = text "... "
474 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
475 hsep (map (ppr . GHC.moduleName) exports)
477 deflt_prompt = dots <> context_bit <> modules_bit
479 f ('%':'s':xs) = deflt_prompt <> f xs
480 f ('%':'%':xs) = char '%' <> f xs
481 f (x:xs) = char x <> f xs
485 return (showSDoc (f (prompt st)))
489 readlineLoop :: GHCi ()
491 session <- getSession
492 (mod,imports) <- io (GHC.getContext session)
494 saveSession -- for use by completion
496 mb_span <- getCurrentBreakSpan
498 l <- io (readline prompt `finally` setNonBlockingFD 0)
499 -- readline sometimes puts stdin into blocking mode,
500 -- so we need to put it back for the IO library
505 case removeSpaces l of
509 quit <- runCommands l
510 if quit then return () else readlineLoop
513 runCommands :: String -> GHCi Bool
515 q <- ghciHandle handler (doCommand cmd)
516 if q then return True else runNext
522 c:cs -> do setGHCiState st{ cmdqueue = cs }
525 doCommand (':' : cmd) = specialCommand cmd
526 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
529 enqueueCommands :: [String] -> GHCi ()
530 enqueueCommands cmds = do
532 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
535 -- This version is for the GHC command-line option -e. The only difference
536 -- from runCommand is that it catches the ExitException exception and
537 -- exits, rather than printing out the exception.
538 runCommandEval c = ghciHandle handleEval (doCommand c)
540 handleEval (ExitException code) = io (exitWith code)
541 handleEval e = do handler e
542 io (exitWith (ExitFailure 1))
544 doCommand (':' : command) = specialCommand command
546 = do r <- runStmt stmt GHC.RunToCompletion
548 False -> io (exitWith (ExitFailure 1))
549 -- failure to run the command causes exit(1) for ghc -e.
552 runStmt :: String -> SingleStep -> GHCi Bool
554 | null (filter (not.isSpace) stmt) = return False
555 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
557 = do st <- getGHCiState
558 session <- getSession
559 result <- io $ withProgName (progname st) $ withArgs (args st) $
560 GHC.runStmt session stmt step
564 afterRunStmt :: GHC.RunResult -> GHCi Bool
565 -- False <=> the statement failed to compile
566 afterRunStmt (GHC.RunException e) = throw e
567 afterRunStmt run_result = do
568 session <- getSession
570 GHC.RunOk names -> do
571 show_types <- isOptionSet ShowType
572 when show_types $ mapM_ (showTypeOfName session) names
573 GHC.RunBreak _ names mb_info -> do
574 resumes <- io $ GHC.getResumeContext session
575 printForUser $ ptext SLIT("Stopped at") <+>
576 ppr (GHC.resumeSpan (head resumes))
577 mapM_ (showTypeOfName session) names
578 maybe (return ()) runBreakCmd mb_info
579 -- run the command set with ":set stop <cmd>"
581 enqueueCommands [stop st]
586 io installSignalHandlers
587 b <- isOptionSet RevertCAFs
588 io (when b revertCAFs)
590 return (case run_result of GHC.RunOk _ -> True; _ -> False)
592 runBreakCmd :: GHC.BreakInfo -> GHCi ()
593 runBreakCmd info = do
594 let mod = GHC.breakInfo_module info
595 nm = GHC.breakInfo_number info
597 case [ loc | (i,loc) <- breaks st,
598 breakModule loc == mod, breakTick loc == nm ] of
600 loc:_ | null cmd -> return ()
601 | otherwise -> do enqueueCommands [cmd]; return ()
602 where cmd = onBreakCmd loc
604 showTypeOfName :: Session -> Name -> GHCi ()
605 showTypeOfName session n
606 = do maybe_tything <- io (GHC.lookupName session n)
607 case maybe_tything of
609 Just thing -> showTyThing thing
611 specialCommand :: String -> GHCi Bool
612 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
613 specialCommand str = do
614 let (cmd,rest) = break isSpace str
615 maybe_cmd <- io (lookupCommand cmd)
617 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
618 ++ shortHelpText) >> return False)
619 Just (_,f,_,_) -> f (dropWhile isSpace rest)
621 lookupCommand :: String -> IO (Maybe Command)
622 lookupCommand str = do
623 cmds <- readIORef commands
624 -- look for exact match first, then the first prefix match
625 case [ c | c <- cmds, str == cmdName c ] of
626 c:_ -> return (Just c)
627 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
629 c:_ -> return (Just c)
632 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
633 getCurrentBreakSpan = do
634 session <- getSession
635 resumes <- io $ GHC.getResumeContext session
639 let ix = GHC.resumeHistoryIx r
641 then return (Just (GHC.resumeSpan r))
643 let hist = GHC.resumeHistory r !! (ix-1)
644 span <- io $ GHC.getHistorySpan session hist
647 -----------------------------------------------------------------------------
650 noArgs :: GHCi () -> String -> GHCi ()
652 noArgs m _ = io $ putStrLn "This command takes no arguments"
654 help :: String -> GHCi ()
655 help _ = io (putStr helpText)
657 info :: String -> GHCi ()
658 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
659 info s = do { let names = words s
660 ; session <- getSession
661 ; dflags <- getDynFlags
662 ; let exts = dopt Opt_GlasgowExts dflags
663 ; mapM_ (infoThing exts session) names }
665 infoThing exts session str = io $ do
666 names <- GHC.parseName session str
667 let filtered = filterOutChildren names
668 mb_stuffs <- mapM (GHC.getInfo session) filtered
669 unqual <- GHC.getPrintUnqual session
670 putStrLn (showSDocForUser unqual $
671 vcat (intersperse (text "") $
672 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
674 -- Filter out names whose parent is also there Good
675 -- example is '[]', which is both a type and data
676 -- constructor in the same type
677 filterOutChildren :: [Name] -> [Name]
678 filterOutChildren names = filter (not . parent_is_there) names
679 where parent_is_there n
680 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
684 pprInfo exts (thing, fixity, insts)
685 = pprTyThingInContextLoc exts thing
686 $$ show_fixity fixity
687 $$ vcat (map GHC.pprInstance insts)
690 | fix == GHC.defaultFixity = empty
691 | otherwise = ppr fix <+> ppr (GHC.getName thing)
693 runMain :: String -> GHCi ()
695 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
696 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
698 addModule :: [FilePath] -> GHCi ()
700 io (revertCAFs) -- always revert CAFs on load/add.
701 files <- mapM expandPath files
702 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
703 session <- getSession
704 io (mapM_ (GHC.addTarget session) targets)
705 ok <- io (GHC.load session LoadAllTargets)
708 changeDirectory :: String -> GHCi ()
709 changeDirectory dir = do
710 session <- getSession
711 graph <- io (GHC.getModuleGraph session)
712 when (not (null graph)) $
713 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
714 io (GHC.setTargets session [])
715 io (GHC.load session LoadAllTargets)
716 setContextAfterLoad session []
717 io (GHC.workingDirectoryChanged session)
718 dir <- expandPath dir
719 io (setCurrentDirectory dir)
721 editFile :: String -> GHCi ()
723 do file <- if null str then chooseEditFile else return str
727 $ throwDyn (CmdLineError "editor not set, use :set editor")
728 io $ system (cmd ++ ' ':file)
731 -- The user didn't specify a file so we pick one for them.
732 -- Our strategy is to pick the first module that failed to load,
733 -- or otherwise the first target.
735 -- XXX: Can we figure out what happened if the depndecy analysis fails
736 -- (e.g., because the porgrammeer mistyped the name of a module)?
737 -- XXX: Can we figure out the location of an error to pass to the editor?
738 -- XXX: if we could figure out the list of errors that occured during the
739 -- last load/reaload, then we could start the editor focused on the first
741 chooseEditFile :: GHCi String
743 do session <- getSession
744 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
746 graph <- io (GHC.getModuleGraph session)
747 failed_graph <- filterM hasFailed graph
748 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
750 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
753 case pick (order failed_graph) of
754 Just file -> return file
756 do targets <- io (GHC.getTargets session)
757 case msum (map fromTarget targets) of
758 Just file -> return file
759 Nothing -> throwDyn (CmdLineError "No files to edit.")
761 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
762 fromTarget _ = Nothing -- when would we get a module target?
764 defineMacro :: String -> GHCi ()
766 let (macro_name, definition) = break isSpace s
767 cmds <- io (readIORef commands)
769 then throwDyn (CmdLineError "invalid macro name")
771 if (macro_name `elem` map cmdName cmds)
772 then throwDyn (CmdLineError
773 ("command '" ++ macro_name ++ "' is already defined"))
776 -- give the expression a type signature, so we can be sure we're getting
777 -- something of the right type.
778 let new_expr = '(' : definition ++ ") :: String -> IO String"
780 -- compile the expression
782 maybe_hv <- io (GHC.compileExpr cms new_expr)
785 Just hv -> io (writeIORef commands --
786 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
788 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
790 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
791 enqueueCommands (lines str)
794 undefineMacro :: String -> GHCi ()
795 undefineMacro macro_name = do
796 cmds <- io (readIORef commands)
797 if (macro_name `elem` map cmdName builtin_commands)
798 then throwDyn (CmdLineError
799 ("command '" ++ macro_name ++ "' cannot be undefined"))
801 if (macro_name `notElem` map cmdName cmds)
802 then throwDyn (CmdLineError
803 ("command '" ++ macro_name ++ "' not defined"))
805 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
807 cmdCmd :: String -> GHCi ()
809 let expr = '(' : str ++ ") :: IO String"
810 session <- getSession
811 maybe_hv <- io (GHC.compileExpr session expr)
815 cmds <- io $ (unsafeCoerce# hv :: IO String)
816 enqueueCommands (lines cmds)
819 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
820 loadModule fs = timeIt (loadModule' fs)
822 loadModule_ :: [FilePath] -> GHCi ()
823 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
825 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
826 loadModule' files = do
827 session <- getSession
830 discardActiveBreakPoints
831 io (GHC.setTargets session [])
832 io (GHC.load session LoadAllTargets)
835 let (filenames, phases) = unzip files
836 exp_filenames <- mapM expandPath filenames
837 let files' = zip exp_filenames phases
838 targets <- io (mapM (uncurry GHC.guessTarget) files')
840 -- NOTE: we used to do the dependency anal first, so that if it
841 -- fails we didn't throw away the current set of modules. This would
842 -- require some re-working of the GHC interface, so we'll leave it
843 -- as a ToDo for now.
845 io (GHC.setTargets session targets)
846 doLoad session LoadAllTargets
848 checkModule :: String -> GHCi ()
850 let modl = GHC.mkModuleName m
851 session <- getSession
852 result <- io (GHC.checkModule session modl)
854 Nothing -> io $ putStrLn "Nothing"
855 Just r -> io $ putStrLn (showSDoc (
856 case GHC.checkedModuleInfo r of
857 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
859 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
861 (text "global names: " <+> ppr global) $$
862 (text "local names: " <+> ppr local)
864 afterLoad (successIf (isJust result)) session
866 reloadModule :: String -> GHCi ()
868 io (revertCAFs) -- always revert CAFs on reload.
869 discardActiveBreakPoints
870 session <- getSession
871 doLoad session $ if null m then LoadAllTargets
872 else LoadUpTo (GHC.mkModuleName m)
875 doLoad session howmuch = do
876 -- turn off breakpoints before we load: we can't turn them off later, because
877 -- the ModBreaks will have gone away.
878 discardActiveBreakPoints
879 ok <- io (GHC.load session howmuch)
883 afterLoad ok session = do
884 io (revertCAFs) -- always revert CAFs on load.
886 graph <- io (GHC.getModuleGraph session)
887 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
888 setContextAfterLoad session graph'
889 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
891 setContextAfterLoad session [] = do
892 prel_mod <- getPrelude
893 io (GHC.setContext session [] [prel_mod])
894 setContextAfterLoad session ms = do
895 -- load a target if one is available, otherwise load the topmost module.
896 targets <- io (GHC.getTargets session)
897 case [ m | Just m <- map (findTarget ms) targets ] of
899 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
900 load_this (last graph')
905 = case filter (`matches` t) ms of
909 summary `matches` Target (TargetModule m) _
910 = GHC.ms_mod_name summary == m
911 summary `matches` Target (TargetFile f _) _
912 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
913 summary `matches` target
916 load_this summary | m <- GHC.ms_mod summary = do
917 b <- io (GHC.moduleIsInterpreted session m)
918 if b then io (GHC.setContext session [m] [])
920 prel_mod <- getPrelude
921 io (GHC.setContext session [] [prel_mod,m])
924 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
925 modulesLoadedMsg ok mods = do
926 dflags <- getDynFlags
927 when (verbosity dflags > 0) $ do
929 | null mods = text "none."
931 punctuate comma (map ppr mods)) <> text "."
934 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
936 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
939 typeOfExpr :: String -> GHCi ()
941 = do cms <- getSession
942 maybe_ty <- io (GHC.exprType cms str)
945 Just ty -> do ty' <- cleanType ty
946 printForUser $ text str <> text " :: " <> ppr ty'
948 kindOfType :: String -> GHCi ()
950 = do cms <- getSession
951 maybe_ty <- io (GHC.typeKind cms str)
954 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
956 quit :: String -> GHCi Bool
959 shellEscape :: String -> GHCi Bool
960 shellEscape str = io (system str >> return False)
962 -----------------------------------------------------------------------------
963 -- Browsing a module's contents
965 browseCmd :: String -> GHCi ()
968 ['*':m] | looksLikeModuleName m -> browseModule m False
969 [m] | looksLikeModuleName m -> browseModule m True
970 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
972 browseModule m exports_only = do
974 modl <- if exports_only then lookupModule m
975 else wantInterpretedModule m
977 -- Temporarily set the context to the module we're interested in,
978 -- just so we can get an appropriate PrintUnqualified
979 (as,bs) <- io (GHC.getContext s)
980 prel_mod <- getPrelude
981 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
982 else GHC.setContext s [modl] [])
983 unqual <- io (GHC.getPrintUnqual s)
984 io (GHC.setContext s as bs)
986 mb_mod_info <- io $ GHC.getModuleInfo s modl
988 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
991 | exports_only = GHC.modInfoExports mod_info
992 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
994 filtered = filterOutChildren names
996 things <- io $ mapM (GHC.lookupName s) filtered
998 dflags <- getDynFlags
999 let exts = dopt Opt_GlasgowExts dflags
1000 io (putStrLn (showSDocForUser unqual (
1001 vcat (map (pprTyThingInContext exts) (catMaybes things))
1003 -- ToDo: modInfoInstances currently throws an exception for
1004 -- package modules. When it works, we can do this:
1005 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1007 -----------------------------------------------------------------------------
1008 -- Setting the module context
1011 | all sensible mods = fn mods
1012 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1014 (fn, mods) = case str of
1015 '+':stuff -> (addToContext, words stuff)
1016 '-':stuff -> (removeFromContext, words stuff)
1017 stuff -> (newContext, words stuff)
1019 sensible ('*':m) = looksLikeModuleName m
1020 sensible m = looksLikeModuleName m
1022 separate :: Session -> [String] -> [Module] -> [Module]
1023 -> GHCi ([Module],[Module])
1024 separate session [] as bs = return (as,bs)
1025 separate session (('*':str):ms) as bs = do
1026 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1027 b <- io $ GHC.moduleIsInterpreted session m
1028 if b then separate session ms (m:as) bs
1029 else throwDyn (CmdLineError ("module '"
1030 ++ GHC.moduleNameString (GHC.moduleName m)
1031 ++ "' is not interpreted"))
1032 separate session (str:ms) as bs = do
1033 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1034 separate session ms as (m:bs)
1036 newContext :: [String] -> GHCi ()
1037 newContext strs = do
1039 (as,bs) <- separate s strs [] []
1040 prel_mod <- getPrelude
1041 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1042 io $ GHC.setContext s as bs'
1045 addToContext :: [String] -> GHCi ()
1046 addToContext strs = do
1048 (as,bs) <- io $ GHC.getContext s
1050 (new_as,new_bs) <- separate s strs [] []
1052 let as_to_add = new_as \\ (as ++ bs)
1053 bs_to_add = new_bs \\ (as ++ bs)
1055 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1058 removeFromContext :: [String] -> GHCi ()
1059 removeFromContext strs = do
1061 (as,bs) <- io $ GHC.getContext s
1063 (as_to_remove,bs_to_remove) <- separate s strs [] []
1065 let as' = as \\ (as_to_remove ++ bs_to_remove)
1066 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1068 io $ GHC.setContext s as' bs'
1070 ----------------------------------------------------------------------------
1073 -- set options in the interpreter. Syntax is exactly the same as the
1074 -- ghc command line, except that certain options aren't available (-C,
1077 -- This is pretty fragile: most options won't work as expected. ToDo:
1078 -- figure out which ones & disallow them.
1080 setCmd :: String -> GHCi ()
1082 = do st <- getGHCiState
1083 let opts = options st
1084 io $ putStrLn (showSDoc (
1085 text "options currently set: " <>
1088 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1091 = case toArgs str of
1092 ("args":args) -> setArgs args
1093 ("prog":prog) -> setProg prog
1094 ("prompt":prompt) -> setPrompt (after 6)
1095 ("editor":cmd) -> setEditor (after 6)
1096 ("stop":cmd) -> setStop (after 4)
1097 wds -> setOptions wds
1098 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1102 setGHCiState st{ args = args }
1106 setGHCiState st{ progname = prog }
1108 io (hPutStrLn stderr "syntax: :set prog <progname>")
1112 setGHCiState st{ editor = cmd }
1114 setStop str@(c:_) | isDigit c
1115 = do let (nm_str,rest) = break (not.isDigit) str
1118 let old_breaks = breaks st
1119 if all ((/= nm) . fst) old_breaks
1120 then printForUser (text "Breakpoint" <+> ppr nm <+>
1121 text "does not exist")
1123 let new_breaks = map fn old_breaks
1124 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1125 | otherwise = (i,loc)
1126 setGHCiState st{ breaks = new_breaks }
1129 setGHCiState st{ stop = cmd }
1131 setPrompt value = do
1134 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1135 else setGHCiState st{ prompt = remQuotes value }
1137 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1141 do -- first, deal with the GHCi opts (+s, +t, etc.)
1142 let (plus_opts, minus_opts) = partition isPlus wds
1143 mapM_ setOpt plus_opts
1144 -- then, dynamic flags
1145 newDynFlags minus_opts
1147 newDynFlags minus_opts = do
1148 dflags <- getDynFlags
1149 let pkg_flags = packageFlags dflags
1150 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1152 if (not (null leftovers))
1153 then throwDyn (CmdLineError ("unrecognised flags: " ++
1157 new_pkgs <- setDynFlags dflags'
1159 -- if the package flags changed, we should reset the context
1160 -- and link the new packages.
1161 dflags <- getDynFlags
1162 when (packageFlags dflags /= pkg_flags) $ do
1163 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1164 session <- getSession
1165 io (GHC.setTargets session [])
1166 io (GHC.load session LoadAllTargets)
1167 io (linkPackages dflags new_pkgs)
1168 setContextAfterLoad session []
1172 unsetOptions :: String -> GHCi ()
1174 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1175 let opts = words str
1176 (minus_opts, rest1) = partition isMinus opts
1177 (plus_opts, rest2) = partition isPlus rest1
1179 if (not (null rest2))
1180 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1183 mapM_ unsetOpt plus_opts
1185 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1186 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1188 no_flags <- mapM no_flag minus_opts
1189 newDynFlags no_flags
1191 isMinus ('-':s) = True
1194 isPlus ('+':s) = True
1198 = case strToGHCiOpt str of
1199 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1200 Just o -> setOption o
1203 = case strToGHCiOpt str of
1204 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1205 Just o -> unsetOption o
1207 strToGHCiOpt :: String -> (Maybe GHCiOption)
1208 strToGHCiOpt "s" = Just ShowTiming
1209 strToGHCiOpt "t" = Just ShowType
1210 strToGHCiOpt "r" = Just RevertCAFs
1211 strToGHCiOpt _ = Nothing
1213 optToStr :: GHCiOption -> String
1214 optToStr ShowTiming = "s"
1215 optToStr ShowType = "t"
1216 optToStr RevertCAFs = "r"
1218 -- ---------------------------------------------------------------------------
1224 ["args"] -> io $ putStrLn (show (args st))
1225 ["prog"] -> io $ putStrLn (show (progname st))
1226 ["prompt"] -> io $ putStrLn (show (prompt st))
1227 ["editor"] -> io $ putStrLn (show (editor st))
1228 ["stop"] -> io $ putStrLn (show (stop st))
1229 ["modules" ] -> showModules
1230 ["bindings"] -> showBindings
1231 ["linker"] -> io showLinkerState
1232 ["breaks"] -> showBkptTable
1233 ["context"] -> showContext
1234 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1237 session <- getSession
1238 let show_one ms = do m <- io (GHC.showModule session ms)
1240 graph <- io (GHC.getModuleGraph session)
1241 mapM_ show_one graph
1245 unqual <- io (GHC.getPrintUnqual s)
1246 bindings <- io (GHC.getBindings s)
1247 mapM_ showTyThing bindings
1250 showTyThing (AnId id) = do
1251 ty' <- cleanType (GHC.idType id)
1252 printForUser $ ppr id <> text " :: " <> ppr ty'
1253 showTyThing _ = return ()
1255 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1256 cleanType :: Type -> GHCi Type
1258 dflags <- getDynFlags
1259 if dopt Opt_GlasgowExts dflags
1261 else return $! GHC.dropForAlls ty
1263 showBkptTable :: GHCi ()
1266 printForUser $ prettyLocations (breaks st)
1268 showContext :: GHCi ()
1270 session <- getSession
1271 resumes <- io $ GHC.getResumeContext session
1272 printForUser $ vcat (map pp_resume (reverse resumes))
1275 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1276 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1279 -- -----------------------------------------------------------------------------
1282 completeNone :: String -> IO [String]
1283 completeNone w = return []
1286 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1287 completeWord w start end = do
1288 line <- Readline.getLineBuffer
1290 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1292 | Just c <- is_cmd line -> do
1293 maybe_cmd <- lookupCommand c
1294 let (n,w') = selectWord (words' 0 line)
1296 Nothing -> return Nothing
1297 Just (_,_,False,complete) -> wrapCompleter complete w
1298 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1299 return (map (drop n) rets)
1300 in wrapCompleter complete' w'
1302 --printf "complete %s, start = %d, end = %d\n" w start end
1303 wrapCompleter completeIdentifier w
1304 where words' _ [] = []
1305 words' n str = let (w,r) = break isSpace str
1306 (s,r') = span isSpace r
1307 in (n,w):words' (n+length w+length s) r'
1308 -- In a Haskell expression we want to parse 'a-b' as three words
1309 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1310 -- only be a single word.
1311 selectWord [] = (0,w)
1312 selectWord ((offset,x):xs)
1313 | offset+length x >= start = (start-offset,take (end-offset) x)
1314 | otherwise = selectWord xs
1317 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1318 | otherwise = Nothing
1321 cmds <- readIORef commands
1322 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1324 completeMacro w = do
1325 cmds <- readIORef commands
1326 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1327 return (filter (w `isPrefixOf`) cmds')
1329 completeIdentifier w = do
1331 rdrs <- GHC.getRdrNamesInScope s
1332 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1334 completeModule w = do
1336 dflags <- GHC.getSessionDynFlags s
1337 let pkg_mods = allExposedModules dflags
1338 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1340 completeHomeModule w = do
1342 g <- GHC.getModuleGraph s
1343 let home_mods = map GHC.ms_mod_name g
1344 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1346 completeSetOptions w = do
1347 return (filter (w `isPrefixOf`) options)
1348 where options = "args":"prog":allFlags
1350 completeFilename = Readline.filenameCompletionFunction
1352 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1354 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1355 unionComplete f1 f2 w = do
1360 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1361 wrapCompleter fun w = do
1364 [] -> return Nothing
1365 [x] -> return (Just (x,[]))
1366 xs -> case getCommonPrefix xs of
1367 "" -> return (Just ("",xs))
1368 pref -> return (Just (pref,xs))
1370 getCommonPrefix :: [String] -> String
1371 getCommonPrefix [] = ""
1372 getCommonPrefix (s:ss) = foldl common s ss
1373 where common s "" = ""
1375 common (c:cs) (d:ds)
1376 | c == d = c : common cs ds
1379 allExposedModules :: DynFlags -> [ModuleName]
1380 allExposedModules dflags
1381 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1383 pkg_db = pkgIdMap (pkgState dflags)
1385 completeCmd = completeNone
1386 completeMacro = completeNone
1387 completeIdentifier = completeNone
1388 completeModule = completeNone
1389 completeHomeModule = completeNone
1390 completeSetOptions = completeNone
1391 completeFilename = completeNone
1392 completeHomeModuleOrFile=completeNone
1393 completeBkpt = completeNone
1396 -- ---------------------------------------------------------------------------
1397 -- User code exception handling
1399 -- This is the exception handler for exceptions generated by the
1400 -- user's code and exceptions coming from children sessions;
1401 -- it normally just prints out the exception. The
1402 -- handler must be recursive, in case showing the exception causes
1403 -- more exceptions to be raised.
1405 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1406 -- raising another exception. We therefore don't put the recursive
1407 -- handler arond the flushing operation, so if stderr is closed
1408 -- GHCi will just die gracefully rather than going into an infinite loop.
1409 handler :: Exception -> GHCi Bool
1411 handler exception = do
1413 io installSignalHandlers
1414 ghciHandle handler (showException exception >> return False)
1416 showException (DynException dyn) =
1417 case fromDynamic dyn of
1418 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1419 Just Interrupted -> io (putStrLn "Interrupted.")
1420 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1421 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1422 Just other_ghc_ex -> io (print other_ghc_ex)
1424 showException other_exception
1425 = io (putStrLn ("*** Exception: " ++ show other_exception))
1427 -----------------------------------------------------------------------------
1428 -- recursive exception handlers
1430 -- Don't forget to unblock async exceptions in the handler, or if we're
1431 -- in an exception loop (eg. let a = error a in a) the ^C exception
1432 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1434 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1435 ghciHandle h (GHCi m) = GHCi $ \s ->
1436 Exception.catch (m s)
1437 (\e -> unGHCi (ghciUnblock (h e)) s)
1439 ghciUnblock :: GHCi a -> GHCi a
1440 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1443 -- ----------------------------------------------------------------------------
1446 expandPath :: String -> GHCi String
1448 case dropWhile isSpace path of
1450 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1451 return (tilde ++ '/':d)
1455 wantInterpretedModule :: String -> GHCi Module
1456 wantInterpretedModule str = do
1457 session <- getSession
1458 modl <- lookupModule str
1459 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1460 when (not is_interpreted) $
1461 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1464 wantNameFromInterpretedModule noCanDo str and_then = do
1465 session <- getSession
1466 names <- io $ GHC.parseName session str
1470 let modl = GHC.nameModule n
1471 if not (GHC.isExternalName n)
1472 then noCanDo n $ ppr n <>
1473 text " is not defined in an interpreted module"
1475 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1476 if not is_interpreted
1477 then noCanDo n $ text "module " <> ppr modl <>
1478 text " is not interpreted"
1481 -- ----------------------------------------------------------------------------
1482 -- Windows console setup
1484 setUpConsole :: IO ()
1486 #ifdef mingw32_HOST_OS
1487 -- On Windows we need to set a known code page, otherwise the characters
1488 -- we read from the console will be be in some strange encoding, and
1489 -- similarly for characters we write to the console.
1491 -- At the moment, GHCi pretends all input is Latin-1. In the
1492 -- future we should support UTF-8, but for now we set the code pages
1495 -- It seems you have to set the font in the console window to
1496 -- a Unicode font in order for output to work properly,
1497 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1498 -- (see MSDN for SetConsoleOutputCP()).
1500 setConsoleCP 28591 -- ISO Latin-1
1501 setConsoleOutputCP 28591 -- ISO Latin-1
1505 -- -----------------------------------------------------------------------------
1506 -- commands for debugger
1508 sprintCmd = pprintCommand False False
1509 printCmd = pprintCommand True False
1510 forceCmd = pprintCommand False True
1512 pprintCommand bind force str = do
1513 session <- getSession
1514 io $ pprintClosureCommand session bind force str
1516 stepCmd :: String -> GHCi ()
1517 stepCmd [] = doContinue GHC.SingleStep
1518 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1520 traceCmd :: String -> GHCi ()
1521 traceCmd [] = doContinue GHC.RunAndLogSteps
1522 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1524 continueCmd :: String -> GHCi ()
1525 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1527 doContinue :: SingleStep -> GHCi ()
1528 doContinue step = do
1529 session <- getSession
1530 runResult <- io $ GHC.resume session step
1531 afterRunStmt runResult
1534 abandonCmd :: String -> GHCi ()
1535 abandonCmd = noArgs $ do
1537 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1538 when (not b) $ io $ putStrLn "There is no computation running."
1541 deleteCmd :: String -> GHCi ()
1542 deleteCmd argLine = do
1543 deleteSwitch $ words argLine
1545 deleteSwitch :: [String] -> GHCi ()
1547 io $ putStrLn "The delete command requires at least one argument."
1548 -- delete all break points
1549 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1550 deleteSwitch idents = do
1551 mapM_ deleteOneBreak idents
1553 deleteOneBreak :: String -> GHCi ()
1555 | all isDigit str = deleteBreak (read str)
1556 | otherwise = return ()
1558 historyCmd :: String -> GHCi ()
1560 | null arg = history 20
1561 | all isDigit arg = history (read arg)
1562 | otherwise = io $ putStrLn "Syntax: :history [num]"
1566 resumes <- io $ GHC.getResumeContext s
1568 [] -> io $ putStrLn "Not stopped at a breakpoint"
1570 let hist = GHC.resumeHistory r
1571 (took,rest) = splitAt num hist
1572 spans <- mapM (io . GHC.getHistorySpan s) took
1573 let nums = map (printf "-%-3d:") [(1::Int)..]
1574 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1575 io $ putStrLn $ if null rest then "<end of history>" else "..."
1577 backCmd :: String -> GHCi ()
1578 backCmd = noArgs $ do
1580 (names, ix, span) <- io $ GHC.back s
1581 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1582 mapM_ (showTypeOfName s) names
1583 -- run the command set with ":set stop <cmd>"
1585 enqueueCommands [stop st]
1587 forwardCmd :: String -> GHCi ()
1588 forwardCmd = noArgs $ do
1590 (names, ix, span) <- io $ GHC.forward s
1591 printForUser $ (if (ix == 0)
1592 then ptext SLIT("Stopped at")
1593 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1594 mapM_ (showTypeOfName s) names
1595 -- run the command set with ":set stop <cmd>"
1597 enqueueCommands [stop st]
1599 -- handle the "break" command
1600 breakCmd :: String -> GHCi ()
1601 breakCmd argLine = do
1602 session <- getSession
1603 breakSwitch session $ words argLine
1605 breakSwitch :: Session -> [String] -> GHCi ()
1606 breakSwitch _session [] = do
1607 io $ putStrLn "The break command requires at least one argument."
1608 breakSwitch session args@(arg1:rest)
1609 | looksLikeModuleName arg1 = do
1610 mod <- wantInterpretedModule arg1
1611 breakByModule session mod rest
1612 | all isDigit arg1 = do
1613 (toplevel, _) <- io $ GHC.getContext session
1615 (mod : _) -> breakByModuleLine mod (read arg1) rest
1617 io $ putStrLn "Cannot find default module for breakpoint."
1618 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1619 | otherwise = do -- try parsing it as an identifier
1620 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1621 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1622 if GHC.isGoodSrcLoc loc
1623 then findBreakAndSet (GHC.nameModule name) $
1624 findBreakByCoord (Just (GHC.srcLocFile loc))
1625 (GHC.srcLocLine loc,
1627 else noCanDo name $ text "can't find its location: " <> ppr loc
1629 noCanDo n why = printForUser $
1630 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1632 breakByModule :: Session -> Module -> [String] -> GHCi ()
1633 breakByModule session mod args@(arg1:rest)
1634 | all isDigit arg1 = do -- looks like a line number
1635 breakByModuleLine mod (read arg1) rest
1636 | otherwise = io $ putStrLn "Invalid arguments to :break"
1638 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1639 breakByModuleLine mod line args
1640 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1641 | [col] <- args, all isDigit col =
1642 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1643 | otherwise = io $ putStrLn "Invalid arguments to :break"
1645 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1646 findBreakAndSet mod lookupTickTree = do
1647 tickArray <- getTickArray mod
1648 (breakArray, _) <- getModBreak mod
1649 case lookupTickTree tickArray of
1650 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1651 Just (tick, span) -> do
1652 success <- io $ setBreakFlag True breakArray tick
1653 session <- getSession
1657 recordBreak $ BreakLocation
1664 text "Breakpoint " <> ppr nm <>
1666 then text " was already set at " <> ppr span
1667 else text " activated at " <> ppr span
1669 printForUser $ text "Breakpoint could not be activated at"
1672 -- When a line number is specified, the current policy for choosing
1673 -- the best breakpoint is this:
1674 -- - the leftmost complete subexpression on the specified line, or
1675 -- - the leftmost subexpression starting on the specified line, or
1676 -- - the rightmost subexpression enclosing the specified line
1678 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1679 findBreakByLine line arr
1680 | not (inRange (bounds arr) line) = Nothing
1682 listToMaybe (sortBy leftmost_largest complete) `mplus`
1683 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1684 listToMaybe (sortBy rightmost ticks)
1688 starts_here = [ tick | tick@(nm,span) <- ticks,
1689 GHC.srcSpanStartLine span == line ]
1691 (complete,incomplete) = partition ends_here starts_here
1692 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1694 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1695 -> Maybe (BreakIndex,SrcSpan)
1696 findBreakByCoord mb_file (line, col) arr
1697 | not (inRange (bounds arr) line) = Nothing
1699 listToMaybe (sortBy rightmost contains) `mplus`
1700 listToMaybe (sortBy leftmost_smallest after_here)
1704 -- the ticks that span this coordinate
1705 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1706 is_correct_file span ]
1708 is_correct_file span
1709 | Just f <- mb_file = GHC.srcSpanFile span == f
1712 after_here = [ tick | tick@(nm,span) <- ticks,
1713 GHC.srcSpanStartLine span == line,
1714 GHC.srcSpanStartCol span >= col ]
1717 leftmost_smallest (_,a) (_,b) = a `compare` b
1718 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1720 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1721 rightmost (_,a) (_,b) = b `compare` a
1723 spans :: SrcSpan -> (Int,Int) -> Bool
1724 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1725 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1727 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1728 -- of carets under the active expression instead. The Windows console
1729 -- doesn't support ANSI escape sequences, and most Unix terminals
1730 -- (including xterm) do, so this is a reasonable guess until we have a
1731 -- proper termcap/terminfo library.
1732 #if !defined(mingw32_TARGET_OS)
1738 start_bold = BS.pack "\ESC[1m"
1739 end_bold = BS.pack "\ESC[0m"
1741 listCmd :: String -> GHCi ()
1743 mb_span <- getCurrentBreakSpan
1745 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1746 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1747 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1748 listCmd str = list2 (words str)
1750 list2 [arg] | all isDigit arg = do
1751 session <- getSession
1752 (toplevel, _) <- io $ GHC.getContext session
1754 [] -> io $ putStrLn "No module to list"
1755 (mod : _) -> listModuleLine mod (read arg)
1756 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1757 mod <- wantInterpretedModule arg1
1758 listModuleLine mod (read arg2)
1760 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1761 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1762 if GHC.isGoodSrcLoc loc
1764 tickArray <- getTickArray (GHC.nameModule name)
1765 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1766 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1769 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1770 Just (_,span) -> io $ listAround span False
1772 noCanDo name $ text "can't find its location: " <>
1775 noCanDo n why = printForUser $
1776 text "cannot list source code for " <> ppr n <> text ": " <> why
1778 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1780 listModuleLine :: Module -> Int -> GHCi ()
1781 listModuleLine modl line = do
1782 session <- getSession
1783 graph <- io (GHC.getModuleGraph session)
1784 let this = filter ((== modl) . GHC.ms_mod) graph
1786 [] -> panic "listModuleLine"
1788 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1789 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1790 io $ listAround (GHC.srcLocSpan loc) False
1792 -- | list a section of a source file around a particular SrcSpan.
1793 -- If the highlight flag is True, also highlight the span using
1794 -- start_bold/end_bold.
1795 listAround span do_highlight = do
1797 contents <- BS.readFile (pwd `joinFileName` unpackFS file)
1799 lines = BS.split '\n' contents
1800 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1801 drop (line1 - 1 - pad_before) $ lines
1802 fst_line = max 1 (line1 - pad_before)
1803 line_nos = [ fst_line .. ]
1805 highlighted | do_highlight = zipWith highlight line_nos these_lines
1806 | otherwise = these_lines
1808 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1809 prefixed = zipWith BS.append bs_line_nos highlighted
1811 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1813 file = GHC.srcSpanFile span
1814 line1 = GHC.srcSpanStartLine span
1815 col1 = GHC.srcSpanStartCol span
1816 line2 = GHC.srcSpanEndLine span
1817 col2 = GHC.srcSpanEndCol span
1819 pad_before | line1 == 1 = 0
1823 highlight | do_bold = highlight_bold
1824 | otherwise = highlight_carets
1826 highlight_bold no line
1827 | no == line1 && no == line2
1828 = let (a,r) = BS.splitAt col1 line
1829 (b,c) = BS.splitAt (col2-col1) r
1831 BS.concat [a,start_bold,b,end_bold,c]
1833 = let (a,b) = BS.splitAt col1 line in
1834 BS.concat [a, start_bold, b]
1836 = let (a,b) = BS.splitAt col2 line in
1837 BS.concat [a, end_bold, b]
1840 highlight_carets no line
1841 | no == line1 && no == line2
1842 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1843 BS.replicate (col2-col1) '^']
1845 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1846 BS.replicate (BS.length line-col1) '^']
1848 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1851 indent = BS.pack " "
1852 nl = BS.singleton '\n'
1854 -- --------------------------------------------------------------------------
1857 getTickArray :: Module -> GHCi TickArray
1858 getTickArray modl = do
1860 let arrmap = tickarrays st
1861 case lookupModuleEnv arrmap modl of
1862 Just arr -> return arr
1864 (breakArray, ticks) <- getModBreak modl
1865 let arr = mkTickArray (assocs ticks)
1866 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1869 discardTickArrays :: GHCi ()
1870 discardTickArrays = do
1872 setGHCiState st{tickarrays = emptyModuleEnv}
1874 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1876 = accumArray (flip (:)) [] (1, max_line)
1877 [ (line, (nm,span)) | (nm,span) <- ticks,
1878 line <- srcSpanLines span ]
1880 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1881 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1882 GHC.srcSpanEndLine span ]
1884 lookupModule :: String -> GHCi Module
1885 lookupModule modName
1886 = do session <- getSession
1887 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1889 -- don't reset the counter back to zero?
1890 discardActiveBreakPoints :: GHCi ()
1891 discardActiveBreakPoints = do
1893 mapM (turnOffBreak.snd) (breaks st)
1894 setGHCiState $ st { breaks = [] }
1896 deleteBreak :: Int -> GHCi ()
1897 deleteBreak identity = do
1899 let oldLocations = breaks st
1900 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1902 then printForUser (text "Breakpoint" <+> ppr identity <+>
1903 text "does not exist")
1905 mapM (turnOffBreak.snd) this
1906 setGHCiState $ st { breaks = rest }
1908 turnOffBreak loc = do
1909 (arr, _) <- getModBreak (breakModule loc)
1910 io $ setBreakFlag False arr (breakTick loc)
1912 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1913 getModBreak mod = do
1914 session <- getSession
1915 Just mod_info <- io $ GHC.getModuleInfo session mod
1916 let modBreaks = GHC.modInfoModBreaks mod_info
1917 let array = GHC.modBreaks_flags modBreaks
1918 let ticks = GHC.modBreaks_locs modBreaks
1919 return (array, ticks)
1921 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1922 setBreakFlag toggle array index
1923 | toggle = GHC.setBreakOn array index
1924 | otherwise = GHC.setBreakOff array index