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