1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
9 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
11 #include "HsVersions.h"
19 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
20 Type, Module, ModuleName, TyThing(..), Phase,
21 BreakIndex, SrcSpan, Resume, SingleStep )
27 import Outputable hiding (printForUser)
28 import Module -- for ModuleEnv
31 -- Other random utilities
33 import BasicTypes hiding (isTopLevel)
34 import Panic hiding (showException)
41 #ifndef mingw32_HOST_OS
42 import System.Posix hiding (getEnv)
44 import GHC.ConsoleHandler ( flushConsole )
45 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
46 import qualified System.Win32
50 import Control.Concurrent ( yield ) -- Used in readline loop
51 import System.Console.Readline as Readline
56 import Control.Exception as Exception
57 -- import Control.Concurrent
59 import qualified Data.ByteString.Char8 as BS
63 import System.Environment
64 import System.Exit ( exitWith, ExitCode(..) )
65 import System.Directory
67 import System.IO.Error as IO
71 import Control.Monad as Monad
74 import Foreign.StablePtr ( newStablePtr )
75 import GHC.Exts ( unsafeCoerce# )
76 import GHC.IOBase ( IOErrorType(InvalidArgument) )
78 import Data.IORef ( IORef, readIORef, writeIORef )
80 import System.Posix.Internals ( setNonBlockingFD )
82 -----------------------------------------------------------------------------
84 ghciWelcomeMsg :: String
85 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
86 ": http://www.haskell.org/ghc/ :? for help"
88 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
91 GLOBAL_VAR(commands, builtin_commands, [Command])
93 builtin_commands :: [Command]
95 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
96 ("?", keepGoing help, False, completeNone),
97 ("add", keepGoingPaths addModule, False, completeFilename),
98 ("abandon", keepGoing abandonCmd, False, completeNone),
99 ("break", keepGoing breakCmd, False, completeIdentifier),
100 ("back", keepGoing backCmd, False, completeNone),
101 ("browse", keepGoing browseCmd, False, completeModule),
102 ("cd", keepGoing changeDirectory, False, completeFilename),
103 ("check", keepGoing checkModule, False, completeHomeModule),
104 ("continue", keepGoing continueCmd, False, completeNone),
105 ("cmd", keepGoing cmdCmd, False, completeIdentifier),
106 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
107 ("def", keepGoing defineMacro, False, completeIdentifier),
108 ("delete", keepGoing deleteCmd, False, completeNone),
109 ("e", keepGoing editFile, False, completeFilename),
110 ("edit", keepGoing editFile, False, completeFilename),
111 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
112 ("force", keepGoing forceCmd, False, completeIdentifier),
113 ("forward", keepGoing forwardCmd, False, completeNone),
114 ("help", keepGoing help, False, completeNone),
115 ("history", keepGoing historyCmd, False, completeNone),
116 ("info", keepGoing info, False, completeIdentifier),
117 ("kind", keepGoing kindOfType, False, completeIdentifier),
118 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
119 ("list", keepGoing listCmd, False, completeNone),
120 ("module", keepGoing setContext, False, completeModule),
121 ("main", keepGoing runMain, False, completeIdentifier),
122 ("print", keepGoing printCmd, False, completeIdentifier),
123 ("quit", quit, False, completeNone),
124 ("reload", keepGoing reloadModule, False, completeNone),
125 ("set", keepGoing setCmd, True, completeSetOptions),
126 ("show", keepGoing showCmd, False, completeNone),
127 ("sprint", keepGoing sprintCmd, False, completeIdentifier),
128 ("step", keepGoing stepCmd, False, completeIdentifier),
129 ("type", keepGoing typeOfExpr, False, completeIdentifier),
130 ("trace", keepGoing traceCmd, False, completeIdentifier),
131 ("undef", keepGoing undefineMacro, False, completeMacro),
132 ("unset", keepGoing unsetOptions, True, completeSetOptions)
135 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
136 keepGoing a str = a str >> return False
138 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
139 keepGoingPaths a str = a (toArgs str) >> return False
141 shortHelpText = "use :? for help.\n"
144 " Commands available from the prompt:\n" ++
146 " <statement> evaluate/run <statement>\n" ++
147 " :add <filename> ... add module(s) to the current target set\n" ++
148 " :browse [*]<module> display the names defined by <module>\n" ++
149 " :cd <dir> change directory to <dir>\n" ++
150 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
151 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
152 " :def <cmd> <expr> define a command :<cmd>\n" ++
153 " :edit <file> edit file\n" ++
154 " :edit edit last module\n" ++
155 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
156 " :help, :? display this list of commands\n" ++
157 " :info [<name> ...] display information about the given names\n" ++
158 " :kind <type> show the kind of <type>\n" ++
159 " :load <filename> ... load module(s) and their dependents\n" ++
160 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
161 " :main [<arguments> ...] run the main function with the given arguments\n" ++
162 " :quit exit GHCi\n" ++
163 " :reload reload the current module set\n" ++
164 " :type <expr> show the type of <expr>\n" ++
165 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
166 " :!<command> run the shell command <command>\n" ++
168 " -- Commands for debugging:\n" ++
170 " :abandon at a breakpoint, abandon current computation\n" ++
171 " :back go back in the history (after :trace)\n" ++
172 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
173 " :break <name> set a breakpoint on the specified function\n" ++
174 " :continue resume after a breakpoint\n" ++
175 " :delete <number> delete the specified breakpoint\n" ++
176 " :delete * delete all breakpoints\n" ++
177 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
178 " :forward go forward in the history (after :back)\n" ++
179 " :history [<n>] show the last <n> items in the history (after :trace)\n" ++
180 " :print [<name> ...] prints a value without forcing its computation\n" ++
181 " :sprint [<name> ...] simplifed version of :print\n" ++
182 " :step single-step after stopping at a breakpoint\n"++
183 " :step <expr> single-step into <expr>\n"++
184 " :trace trace after stopping at a breakpoint\n"++
185 " :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
188 " -- Commands for changing settings:\n" ++
190 " :set <option> ... set options\n" ++
191 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
192 " :set prog <progname> set the value returned by System.getProgName\n" ++
193 " :set prompt <prompt> set the prompt used in GHCi\n" ++
194 " :set editor <cmd> set the command used for :edit\n" ++
195 " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
196 " :unset <option> ... unset options\n" ++
198 " Options for ':set' and ':unset':\n" ++
200 " +r revert top-level expressions after each evaluation\n" ++
201 " +s print timing/memory stats after each evaluation\n" ++
202 " +t print type after evaluation\n" ++
203 " -<flags> most GHC command line flags can also be set here\n" ++
204 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
206 " -- Commands for displaying information:\n" ++
208 " :show bindings show the current bindings made at the prompt\n" ++
209 " :show breaks show the active breakpoints\n" ++
210 " :show context show the breakpoint context\n" ++
211 " :show modules show the currently loaded modules\n" ++
212 " :show <setting> show anything that can be set with :set (e.g. args)\n" ++
219 win <- System.Win32.getWindowsDirectory
220 return (win `joinFileName` "notepad.exe")
225 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
226 interactiveUI session srcs maybe_expr = do
227 -- HACK! If we happen to get into an infinite loop (eg the user
228 -- types 'let x=x in x' at the prompt), then the thread will block
229 -- on a blackhole, and become unreachable during GC. The GC will
230 -- detect that it is unreachable and send it the NonTermination
231 -- exception. However, since the thread is unreachable, everything
232 -- it refers to might be finalized, including the standard Handles.
233 -- This sounds like a bug, but we don't have a good solution right
239 -- Initialise buffering for the *interpreted* I/O system
240 initInterpBuffering session
242 when (isNothing maybe_expr) $ do
243 -- Only for GHCi (not runghc and ghc -e):
245 -- Turn buffering off for the compiled program's stdout/stderr
247 -- Turn buffering off for GHCi's stdout
249 hSetBuffering stdout NoBuffering
250 -- We don't want the cmd line to buffer any input that might be
251 -- intended for the program, so unbuffer stdin.
252 hSetBuffering stdin NoBuffering
254 -- initial context is just the Prelude
255 prel_mod <- GHC.findModule session prel_name (Just basePackageId)
256 GHC.setContext session [] [prel_mod]
260 Readline.setAttemptedCompletionFunction (Just completeWord)
261 --Readline.parseAndBind "set show-all-if-ambiguous 1"
263 let symbols = "!#$%&*+/<=>?@\\^|-~"
264 specials = "(),;[]`{}"
266 word_break_chars = spaces ++ specials ++ symbols
268 Readline.setBasicWordBreakCharacters word_break_chars
269 Readline.setCompleterWordBreakCharacters word_break_chars
272 default_editor <- findEditor
274 startGHCi (runGHCi srcs maybe_expr)
275 GHCiState{ progname = "<interactive>",
279 editor = default_editor,
285 tickarrays = emptyModuleEnv,
290 Readline.resetTerminal Nothing
295 prel_name = GHC.mkModuleName "Prelude"
297 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
298 runGHCi paths maybe_expr = do
299 let read_dot_files = not opt_IgnoreDotGhci
301 when (read_dot_files) $ do
304 exists <- io (doesFileExist file)
306 dir_ok <- io (checkPerms ".")
307 file_ok <- io (checkPerms file)
308 when (dir_ok && file_ok) $ do
309 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
312 Right hdl -> fileLoop hdl False
314 when (read_dot_files) $ do
315 -- Read in $HOME/.ghci
316 either_dir <- io (IO.try (getEnv "HOME"))
320 cwd <- io (getCurrentDirectory)
321 when (dir /= cwd) $ do
322 let file = dir ++ "/.ghci"
323 ok <- io (checkPerms file)
325 either_hdl <- io (IO.try (openFile file ReadMode))
328 Right hdl -> fileLoop hdl False
330 -- Perform a :load for files given on the GHCi command line
331 -- When in -e mode, if the load fails then we want to stop
332 -- immediately rather than going on to evaluate the expression.
333 when (not (null paths)) $ do
334 ok <- ghciHandle (\e -> do showException e; return Failed) $
336 when (isJust maybe_expr && failed ok) $
337 io (exitWith (ExitFailure 1))
339 -- if verbosity is greater than 0, or we are connected to a
340 -- terminal, display the prompt in the interactive loop.
341 is_tty <- io (hIsTerminalDevice stdin)
342 dflags <- getDynFlags
343 let show_prompt = verbosity dflags > 0 || is_tty
348 #if defined(mingw32_HOST_OS)
349 -- The win32 Console API mutates the first character of
350 -- type-ahead when reading from it in a non-buffered manner. Work
351 -- around this by flushing the input buffer of type-ahead characters,
352 -- but only if stdin is available.
353 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
355 Left err | isDoesNotExistError err -> return ()
356 | otherwise -> io (ioError err)
357 Right () -> return ()
359 -- initialise the console if necessary
362 -- enter the interactive loop
363 interactiveLoop is_tty show_prompt
365 -- just evaluate the expression we were given
370 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
373 interactiveLoop is_tty show_prompt =
374 -- Ignore ^C exceptions caught here
375 ghciHandleDyn (\e -> case e of
377 #if defined(mingw32_HOST_OS)
380 interactiveLoop is_tty show_prompt
381 _other -> return ()) $
383 ghciUnblock $ do -- unblock necessary if we recursed from the
384 -- exception handler above.
386 -- read commands from stdin
390 else fileLoop stdin show_prompt
392 fileLoop stdin show_prompt
396 -- NOTE: We only read .ghci files if they are owned by the current user,
397 -- and aren't world writable. Otherwise, we could be accidentally
398 -- running code planted by a malicious third party.
400 -- Furthermore, We only read ./.ghci if . is owned by the current user
401 -- and isn't writable by anyone else. I think this is sufficient: we
402 -- don't need to check .. and ../.. etc. because "." always refers to
403 -- the same directory while a process is running.
405 checkPerms :: String -> IO Bool
407 #ifdef mingw32_HOST_OS
410 Util.handle (\_ -> return False) $ do
411 st <- getFileStatus name
413 if fileOwner st /= me then do
414 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
417 let mode = fileMode st
418 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
419 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
421 putStrLn $ "*** WARNING: " ++ name ++
422 " is writable by someone else, IGNORING!"
427 fileLoop :: Handle -> Bool -> GHCi ()
428 fileLoop hdl show_prompt = do
429 when show_prompt $ do
432 l <- io (IO.try (hGetLine hdl))
434 Left e | isEOFError e -> return ()
435 | InvalidArgument <- etype -> return ()
436 | otherwise -> io (ioError e)
437 where etype = ioeGetErrorType e
438 -- treat InvalidArgument in the same way as EOF:
439 -- this can happen if the user closed stdin, or
440 -- perhaps did getContents which closes stdin at
443 case removeSpaces l of
444 "" -> fileLoop hdl show_prompt
445 l -> do quit <- runCommands l
446 if quit then return () else fileLoop hdl show_prompt
449 session <- getSession
450 (toplevs,exports) <- io (GHC.getContext session)
451 resumes <- io $ GHC.getResumeContext session
457 let ix = GHC.resumeHistoryIx r
459 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
461 let hist = GHC.resumeHistory r !! (ix-1)
462 span <- io $ GHC.getHistorySpan session hist
463 return (brackets (ppr (negate ix) <> char ':'
464 <+> ppr span) <> space)
466 dots | r:rs <- resumes, not (null rs) = text "... "
470 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
471 hsep (map (ppr . GHC.moduleName) exports)
473 deflt_prompt = dots <> context_bit <> modules_bit
475 f ('%':'s':xs) = deflt_prompt <> f xs
476 f ('%':'%':xs) = char '%' <> f xs
477 f (x:xs) = char x <> f xs
481 return (showSDoc (f (prompt st)))
485 readlineLoop :: GHCi ()
487 session <- getSession
488 (mod,imports) <- io (GHC.getContext session)
490 saveSession -- for use by completion
492 mb_span <- getCurrentBreakSpan
494 l <- io (readline prompt `finally` setNonBlockingFD 0)
495 -- readline sometimes puts stdin into blocking mode,
496 -- so we need to put it back for the IO library
501 case removeSpaces l of
505 quit <- runCommands l
506 if quit then return () else readlineLoop
509 runCommands :: String -> GHCi Bool
511 q <- ghciHandle handler (doCommand cmd)
512 if q then return True else runNext
518 c:cs -> do setGHCiState st{ cmdqueue = cs }
521 doCommand (':' : cmd) = specialCommand cmd
522 doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
525 enqueueCommands :: [String] -> GHCi ()
526 enqueueCommands cmds = do
528 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
531 -- This version is for the GHC command-line option -e. The only difference
532 -- from runCommand is that it catches the ExitException exception and
533 -- exits, rather than printing out the exception.
534 runCommandEval c = ghciHandle handleEval (doCommand c)
536 handleEval (ExitException code) = io (exitWith code)
537 handleEval e = do handler e
538 io (exitWith (ExitFailure 1))
540 doCommand (':' : command) = specialCommand command
542 = do r <- runStmt stmt GHC.RunToCompletion
544 False -> io (exitWith (ExitFailure 1))
545 -- failure to run the command causes exit(1) for ghc -e.
548 runStmt :: String -> SingleStep -> GHCi Bool
550 | null (filter (not.isSpace) stmt) = return False
551 | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
553 = do st <- getGHCiState
554 session <- getSession
555 result <- io $ withProgName (progname st) $ withArgs (args st) $
556 GHC.runStmt session stmt step
560 afterRunStmt :: GHC.RunResult -> GHCi Bool
561 -- False <=> the statement failed to compile
562 afterRunStmt (GHC.RunException e) = throw e
563 afterRunStmt run_result = do
564 session <- getSession
566 GHC.RunOk names -> do
567 show_types <- isOptionSet ShowType
568 when show_types $ printTypeOfNames session names
569 GHC.RunBreak _ names mb_info -> do
570 resumes <- io $ GHC.getResumeContext session
571 printForUser $ ptext SLIT("Stopped at") <+>
572 ppr (GHC.resumeSpan (head resumes))
573 printTypeOfNames session names
574 maybe (return ()) runBreakCmd mb_info
575 -- run the command set with ":set stop <cmd>"
577 enqueueCommands [stop st]
582 io installSignalHandlers
583 b <- isOptionSet RevertCAFs
584 io (when b revertCAFs)
586 return (case run_result of GHC.RunOk _ -> True; _ -> False)
588 runBreakCmd :: GHC.BreakInfo -> GHCi ()
589 runBreakCmd info = do
590 let mod = GHC.breakInfo_module info
591 nm = GHC.breakInfo_number info
593 case [ loc | (i,loc) <- breaks st,
594 breakModule loc == mod, breakTick loc == nm ] of
596 loc:_ | null cmd -> return ()
597 | otherwise -> do enqueueCommands [cmd]; return ()
598 where cmd = onBreakCmd loc
600 printTypeOfNames :: Session -> [Name] -> GHCi ()
601 printTypeOfNames session names
602 = mapM_ (printTypeOfName session) $ sortBy compareNames names
604 compareNames :: Name -> Name -> Ordering
605 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
606 where compareWith n = (getOccString n, getSrcSpan n)
608 printTypeOfName :: Session -> Name -> GHCi ()
609 printTypeOfName session n
610 = do maybe_tything <- io (GHC.lookupName session n)
611 case maybe_tything of
613 Just thing -> printTyThing thing
615 specialCommand :: String -> GHCi Bool
616 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
617 specialCommand str = do
618 let (cmd,rest) = break isSpace str
619 maybe_cmd <- io (lookupCommand cmd)
621 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
622 ++ shortHelpText) >> return False)
623 Just (_,f,_,_) -> f (dropWhile isSpace rest)
625 lookupCommand :: String -> IO (Maybe Command)
626 lookupCommand str = do
627 cmds <- readIORef commands
628 -- look for exact match first, then the first prefix match
629 case [ c | c <- cmds, str == cmdName c ] of
630 c:_ -> return (Just c)
631 [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
633 c:_ -> return (Just c)
636 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
637 getCurrentBreakSpan = do
638 session <- getSession
639 resumes <- io $ GHC.getResumeContext session
643 let ix = GHC.resumeHistoryIx r
645 then return (Just (GHC.resumeSpan r))
647 let hist = GHC.resumeHistory r !! (ix-1)
648 span <- io $ GHC.getHistorySpan session hist
651 -----------------------------------------------------------------------------
654 noArgs :: GHCi () -> String -> GHCi ()
656 noArgs m _ = io $ putStrLn "This command takes no arguments"
658 help :: String -> GHCi ()
659 help _ = io (putStr helpText)
661 info :: String -> GHCi ()
662 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
663 info s = do { let names = words s
664 ; session <- getSession
665 ; dflags <- getDynFlags
666 ; let exts = dopt Opt_GlasgowExts dflags
667 ; mapM_ (infoThing exts session) names }
669 infoThing exts session str = io $ do
670 names <- GHC.parseName session str
671 let filtered = filterOutChildren names
672 mb_stuffs <- mapM (GHC.getInfo session) filtered
673 unqual <- GHC.getPrintUnqual session
674 putStrLn (showSDocForUser unqual $
675 vcat (intersperse (text "") $
676 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
678 -- Filter out names whose parent is also there Good
679 -- example is '[]', which is both a type and data
680 -- constructor in the same type
681 filterOutChildren :: [Name] -> [Name]
682 filterOutChildren names = filter (not . parent_is_there) names
683 where parent_is_there n
684 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
688 pprInfo exts (thing, fixity, insts)
689 = pprTyThingInContextLoc exts thing
690 $$ show_fixity fixity
691 $$ vcat (map GHC.pprInstance insts)
694 | fix == GHC.defaultFixity = empty
695 | otherwise = ppr fix <+> ppr (GHC.getName thing)
697 runMain :: String -> GHCi ()
699 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
700 enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
702 addModule :: [FilePath] -> GHCi ()
704 io (revertCAFs) -- always revert CAFs on load/add.
705 files <- mapM expandPath files
706 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
707 session <- getSession
708 io (mapM_ (GHC.addTarget session) targets)
709 ok <- io (GHC.load session LoadAllTargets)
712 changeDirectory :: String -> GHCi ()
713 changeDirectory dir = do
714 session <- getSession
715 graph <- io (GHC.getModuleGraph session)
716 when (not (null graph)) $
717 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
718 io (GHC.setTargets session [])
719 io (GHC.load session LoadAllTargets)
720 setContextAfterLoad session []
721 io (GHC.workingDirectoryChanged session)
722 dir <- expandPath dir
723 io (setCurrentDirectory dir)
725 editFile :: String -> GHCi ()
727 do file <- if null str then chooseEditFile else return str
731 $ throwDyn (CmdLineError "editor not set, use :set editor")
732 io $ system (cmd ++ ' ':file)
735 -- The user didn't specify a file so we pick one for them.
736 -- Our strategy is to pick the first module that failed to load,
737 -- or otherwise the first target.
739 -- XXX: Can we figure out what happened if the depndecy analysis fails
740 -- (e.g., because the porgrammeer mistyped the name of a module)?
741 -- XXX: Can we figure out the location of an error to pass to the editor?
742 -- XXX: if we could figure out the list of errors that occured during the
743 -- last load/reaload, then we could start the editor focused on the first
745 chooseEditFile :: GHCi String
747 do session <- getSession
748 let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
750 graph <- io (GHC.getModuleGraph session)
751 failed_graph <- filterM hasFailed graph
752 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
754 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
757 case pick (order failed_graph) of
758 Just file -> return file
760 do targets <- io (GHC.getTargets session)
761 case msum (map fromTarget targets) of
762 Just file -> return file
763 Nothing -> throwDyn (CmdLineError "No files to edit.")
765 where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
766 fromTarget _ = Nothing -- when would we get a module target?
768 defineMacro :: String -> GHCi ()
770 let (macro_name, definition) = break isSpace s
771 cmds <- io (readIORef commands)
773 then throwDyn (CmdLineError "invalid macro name")
775 if (macro_name `elem` map cmdName cmds)
776 then throwDyn (CmdLineError
777 ("command '" ++ macro_name ++ "' is already defined"))
780 -- give the expression a type signature, so we can be sure we're getting
781 -- something of the right type.
782 let new_expr = '(' : definition ++ ") :: String -> IO String"
784 -- compile the expression
786 maybe_hv <- io (GHC.compileExpr cms new_expr)
789 Just hv -> io (writeIORef commands --
790 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
792 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
794 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
795 enqueueCommands (lines str)
798 undefineMacro :: String -> GHCi ()
799 undefineMacro macro_name = do
800 cmds <- io (readIORef commands)
801 if (macro_name `elem` map cmdName builtin_commands)
802 then throwDyn (CmdLineError
803 ("command '" ++ macro_name ++ "' cannot be undefined"))
805 if (macro_name `notElem` map cmdName cmds)
806 then throwDyn (CmdLineError
807 ("command '" ++ macro_name ++ "' not defined"))
809 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
811 cmdCmd :: String -> GHCi ()
813 let expr = '(' : str ++ ") :: IO String"
814 session <- getSession
815 maybe_hv <- io (GHC.compileExpr session expr)
819 cmds <- io $ (unsafeCoerce# hv :: IO String)
820 enqueueCommands (lines cmds)
823 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
824 loadModule fs = timeIt (loadModule' fs)
826 loadModule_ :: [FilePath] -> GHCi ()
827 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
829 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
830 loadModule' files = do
831 session <- getSession
834 discardActiveBreakPoints
835 io (GHC.setTargets session [])
836 io (GHC.load session LoadAllTargets)
839 let (filenames, phases) = unzip files
840 exp_filenames <- mapM expandPath filenames
841 let files' = zip exp_filenames phases
842 targets <- io (mapM (uncurry GHC.guessTarget) files')
844 -- NOTE: we used to do the dependency anal first, so that if it
845 -- fails we didn't throw away the current set of modules. This would
846 -- require some re-working of the GHC interface, so we'll leave it
847 -- as a ToDo for now.
849 io (GHC.setTargets session targets)
850 doLoad session LoadAllTargets
852 checkModule :: String -> GHCi ()
854 let modl = GHC.mkModuleName m
855 session <- getSession
856 result <- io (GHC.checkModule session modl False)
858 Nothing -> io $ putStrLn "Nothing"
859 Just r -> io $ putStrLn (showSDoc (
860 case GHC.checkedModuleInfo r of
861 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
863 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
865 (text "global names: " <+> ppr global) $$
866 (text "local names: " <+> ppr local)
868 afterLoad (successIf (isJust result)) session
870 reloadModule :: String -> GHCi ()
872 io (revertCAFs) -- always revert CAFs on reload.
873 discardActiveBreakPoints
874 session <- getSession
875 doLoad session $ if null m then LoadAllTargets
876 else LoadUpTo (GHC.mkModuleName m)
879 doLoad session howmuch = do
880 -- turn off breakpoints before we load: we can't turn them off later, because
881 -- the ModBreaks will have gone away.
882 discardActiveBreakPoints
883 ok <- io (GHC.load session howmuch)
887 afterLoad ok session = do
888 io (revertCAFs) -- always revert CAFs on load.
890 graph <- io (GHC.getModuleGraph session)
891 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
892 setContextAfterLoad session graph'
893 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
895 setContextAfterLoad session [] = do
896 prel_mod <- getPrelude
897 io (GHC.setContext session [] [prel_mod])
898 setContextAfterLoad session ms = do
899 -- load a target if one is available, otherwise load the topmost module.
900 targets <- io (GHC.getTargets session)
901 case [ m | Just m <- map (findTarget ms) targets ] of
903 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
904 load_this (last graph')
909 = case filter (`matches` t) ms of
913 summary `matches` Target (TargetModule m) _
914 = GHC.ms_mod_name summary == m
915 summary `matches` Target (TargetFile f _) _
916 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
917 summary `matches` target
920 load_this summary | m <- GHC.ms_mod summary = do
921 b <- io (GHC.moduleIsInterpreted session m)
922 if b then io (GHC.setContext session [m] [])
924 prel_mod <- getPrelude
925 io (GHC.setContext session [] [prel_mod,m])
928 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
929 modulesLoadedMsg ok mods = do
930 dflags <- getDynFlags
931 when (verbosity dflags > 0) $ do
933 | null mods = text "none."
935 punctuate comma (map ppr mods)) <> text "."
938 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
940 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
943 typeOfExpr :: String -> GHCi ()
945 = do cms <- getSession
946 maybe_ty <- io (GHC.exprType cms str)
949 Just ty -> do ty' <- cleanType ty
950 printForUser $ text str <> text " :: " <> ppr ty'
952 kindOfType :: String -> GHCi ()
954 = do cms <- getSession
955 maybe_ty <- io (GHC.typeKind cms str)
958 Just ty -> printForUser $ text str <> text " :: " <> ppr ty
960 quit :: String -> GHCi Bool
963 shellEscape :: String -> GHCi Bool
964 shellEscape str = io (system str >> return False)
966 -----------------------------------------------------------------------------
967 -- Browsing a module's contents
969 browseCmd :: String -> GHCi ()
972 ['*':m] | looksLikeModuleName m -> browseModule m False
973 [m] | looksLikeModuleName m -> browseModule m True
974 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
976 browseModule m exports_only = do
978 modl <- if exports_only then lookupModule m
979 else wantInterpretedModule m
981 -- Temporarily set the context to the module we're interested in,
982 -- just so we can get an appropriate PrintUnqualified
983 (as,bs) <- io (GHC.getContext s)
984 prel_mod <- getPrelude
985 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
986 else GHC.setContext s [modl] [])
987 unqual <- io (GHC.getPrintUnqual s)
988 io (GHC.setContext s as bs)
990 mb_mod_info <- io $ GHC.getModuleInfo s modl
992 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
995 | exports_only = GHC.modInfoExports mod_info
996 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
998 filtered = filterOutChildren names
1000 things <- io $ mapM (GHC.lookupName s) filtered
1002 dflags <- getDynFlags
1003 let exts = dopt Opt_GlasgowExts dflags
1004 io (putStrLn (showSDocForUser unqual (
1005 vcat (map (pprTyThingInContext exts) (catMaybes things))
1007 -- ToDo: modInfoInstances currently throws an exception for
1008 -- package modules. When it works, we can do this:
1009 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1011 -----------------------------------------------------------------------------
1012 -- Setting the module context
1015 | all sensible mods = fn mods
1016 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1018 (fn, mods) = case str of
1019 '+':stuff -> (addToContext, words stuff)
1020 '-':stuff -> (removeFromContext, words stuff)
1021 stuff -> (newContext, words stuff)
1023 sensible ('*':m) = looksLikeModuleName m
1024 sensible m = looksLikeModuleName m
1026 separate :: Session -> [String] -> [Module] -> [Module]
1027 -> GHCi ([Module],[Module])
1028 separate session [] as bs = return (as,bs)
1029 separate session (('*':str):ms) as bs = do
1030 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1031 b <- io $ GHC.moduleIsInterpreted session m
1032 if b then separate session ms (m:as) bs
1033 else throwDyn (CmdLineError ("module '"
1034 ++ GHC.moduleNameString (GHC.moduleName m)
1035 ++ "' is not interpreted"))
1036 separate session (str:ms) as bs = do
1037 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1038 separate session ms as (m:bs)
1040 newContext :: [String] -> GHCi ()
1041 newContext strs = do
1043 (as,bs) <- separate s strs [] []
1044 prel_mod <- getPrelude
1045 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1046 io $ GHC.setContext s as bs'
1049 addToContext :: [String] -> GHCi ()
1050 addToContext strs = do
1052 (as,bs) <- io $ GHC.getContext s
1054 (new_as,new_bs) <- separate s strs [] []
1056 let as_to_add = new_as \\ (as ++ bs)
1057 bs_to_add = new_bs \\ (as ++ bs)
1059 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1062 removeFromContext :: [String] -> GHCi ()
1063 removeFromContext strs = do
1065 (as,bs) <- io $ GHC.getContext s
1067 (as_to_remove,bs_to_remove) <- separate s strs [] []
1069 let as' = as \\ (as_to_remove ++ bs_to_remove)
1070 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1072 io $ GHC.setContext s as' bs'
1074 ----------------------------------------------------------------------------
1077 -- set options in the interpreter. Syntax is exactly the same as the
1078 -- ghc command line, except that certain options aren't available (-C,
1081 -- This is pretty fragile: most options won't work as expected. ToDo:
1082 -- figure out which ones & disallow them.
1084 setCmd :: String -> GHCi ()
1086 = do st <- getGHCiState
1087 let opts = options st
1088 io $ putStrLn (showSDoc (
1089 text "options currently set: " <>
1092 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1095 = case toArgs str of
1096 ("args":args) -> setArgs args
1097 ("prog":prog) -> setProg prog
1098 ("prompt":prompt) -> setPrompt (after 6)
1099 ("editor":cmd) -> setEditor (after 6)
1100 ("stop":cmd) -> setStop (after 4)
1101 wds -> setOptions wds
1102 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1106 setGHCiState st{ args = args }
1110 setGHCiState st{ progname = prog }
1112 io (hPutStrLn stderr "syntax: :set prog <progname>")
1116 setGHCiState st{ editor = cmd }
1118 setStop str@(c:_) | isDigit c
1119 = do let (nm_str,rest) = break (not.isDigit) str
1122 let old_breaks = breaks st
1123 if all ((/= nm) . fst) old_breaks
1124 then printForUser (text "Breakpoint" <+> ppr nm <+>
1125 text "does not exist")
1127 let new_breaks = map fn old_breaks
1128 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1129 | otherwise = (i,loc)
1130 setGHCiState st{ breaks = new_breaks }
1133 setGHCiState st{ stop = cmd }
1135 setPrompt value = do
1138 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1139 else setGHCiState st{ prompt = remQuotes value }
1141 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1145 do -- first, deal with the GHCi opts (+s, +t, etc.)
1146 let (plus_opts, minus_opts) = partition isPlus wds
1147 mapM_ setOpt plus_opts
1148 -- then, dynamic flags
1149 newDynFlags minus_opts
1151 newDynFlags minus_opts = do
1152 dflags <- getDynFlags
1153 let pkg_flags = packageFlags dflags
1154 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1156 if (not (null leftovers))
1157 then throwDyn (CmdLineError ("unrecognised flags: " ++
1161 new_pkgs <- setDynFlags dflags'
1163 -- if the package flags changed, we should reset the context
1164 -- and link the new packages.
1165 dflags <- getDynFlags
1166 when (packageFlags dflags /= pkg_flags) $ do
1167 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1168 session <- getSession
1169 io (GHC.setTargets session [])
1170 io (GHC.load session LoadAllTargets)
1171 io (linkPackages dflags new_pkgs)
1172 setContextAfterLoad session []
1176 unsetOptions :: String -> GHCi ()
1178 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1179 let opts = words str
1180 (minus_opts, rest1) = partition isMinus opts
1181 (plus_opts, rest2) = partition isPlus rest1
1183 if (not (null rest2))
1184 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1187 mapM_ unsetOpt plus_opts
1189 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1190 no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1192 no_flags <- mapM no_flag minus_opts
1193 newDynFlags no_flags
1195 isMinus ('-':s) = True
1198 isPlus ('+':s) = True
1202 = case strToGHCiOpt str of
1203 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1204 Just o -> setOption o
1207 = case strToGHCiOpt str of
1208 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1209 Just o -> unsetOption o
1211 strToGHCiOpt :: String -> (Maybe GHCiOption)
1212 strToGHCiOpt "s" = Just ShowTiming
1213 strToGHCiOpt "t" = Just ShowType
1214 strToGHCiOpt "r" = Just RevertCAFs
1215 strToGHCiOpt _ = Nothing
1217 optToStr :: GHCiOption -> String
1218 optToStr ShowTiming = "s"
1219 optToStr ShowType = "t"
1220 optToStr RevertCAFs = "r"
1222 -- ---------------------------------------------------------------------------
1228 ["args"] -> io $ putStrLn (show (args st))
1229 ["prog"] -> io $ putStrLn (show (progname st))
1230 ["prompt"] -> io $ putStrLn (show (prompt st))
1231 ["editor"] -> io $ putStrLn (show (editor st))
1232 ["stop"] -> io $ putStrLn (show (stop st))
1233 ["modules" ] -> showModules
1234 ["bindings"] -> showBindings
1235 ["linker"] -> io showLinkerState
1236 ["breaks"] -> showBkptTable
1237 ["context"] -> showContext
1238 _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1241 session <- getSession
1242 let show_one ms = do m <- io (GHC.showModule session ms)
1244 graph <- io (GHC.getModuleGraph session)
1245 mapM_ show_one graph
1249 unqual <- io (GHC.getPrintUnqual s)
1250 bindings <- io (GHC.getBindings s)
1251 mapM_ printTyThing $ sortBy compareTyThings bindings
1254 compareTyThings :: TyThing -> TyThing -> Ordering
1255 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1257 printTyThing :: TyThing -> GHCi ()
1258 printTyThing (AnId id) = do
1259 ty' <- cleanType (GHC.idType id)
1260 printForUser $ ppr id <> text " :: " <> ppr ty'
1261 printTyThing _ = return ()
1263 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1264 cleanType :: Type -> GHCi Type
1266 dflags <- getDynFlags
1267 if dopt Opt_GlasgowExts dflags
1269 else return $! GHC.dropForAlls ty
1271 showBkptTable :: GHCi ()
1274 printForUser $ prettyLocations (breaks st)
1276 showContext :: GHCi ()
1278 session <- getSession
1279 resumes <- io $ GHC.getResumeContext session
1280 printForUser $ vcat (map pp_resume (reverse resumes))
1283 ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1284 $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1287 -- -----------------------------------------------------------------------------
1290 completeNone :: String -> IO [String]
1291 completeNone w = return []
1294 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1295 completeWord w start end = do
1296 line <- Readline.getLineBuffer
1298 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1300 | Just c <- is_cmd line -> do
1301 maybe_cmd <- lookupCommand c
1302 let (n,w') = selectWord (words' 0 line)
1304 Nothing -> return Nothing
1305 Just (_,_,False,complete) -> wrapCompleter complete w
1306 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1307 return (map (drop n) rets)
1308 in wrapCompleter complete' w'
1310 --printf "complete %s, start = %d, end = %d\n" w start end
1311 wrapCompleter completeIdentifier w
1312 where words' _ [] = []
1313 words' n str = let (w,r) = break isSpace str
1314 (s,r') = span isSpace r
1315 in (n,w):words' (n+length w+length s) r'
1316 -- In a Haskell expression we want to parse 'a-b' as three words
1317 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1318 -- only be a single word.
1319 selectWord [] = (0,w)
1320 selectWord ((offset,x):xs)
1321 | offset+length x >= start = (start-offset,take (end-offset) x)
1322 | otherwise = selectWord xs
1325 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1326 | otherwise = Nothing
1329 cmds <- readIORef commands
1330 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1332 completeMacro w = do
1333 cmds <- readIORef commands
1334 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1335 return (filter (w `isPrefixOf`) cmds')
1337 completeIdentifier w = do
1339 rdrs <- GHC.getRdrNamesInScope s
1340 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1342 completeModule w = do
1344 dflags <- GHC.getSessionDynFlags s
1345 let pkg_mods = allExposedModules dflags
1346 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1348 completeHomeModule w = do
1350 g <- GHC.getModuleGraph s
1351 let home_mods = map GHC.ms_mod_name g
1352 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1354 completeSetOptions w = do
1355 return (filter (w `isPrefixOf`) options)
1356 where options = "args":"prog":allFlags
1358 completeFilename = Readline.filenameCompletionFunction
1360 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1362 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1363 unionComplete f1 f2 w = do
1368 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1369 wrapCompleter fun w = do
1372 [] -> return Nothing
1373 [x] -> return (Just (x,[]))
1374 xs -> case getCommonPrefix xs of
1375 "" -> return (Just ("",xs))
1376 pref -> return (Just (pref,xs))
1378 getCommonPrefix :: [String] -> String
1379 getCommonPrefix [] = ""
1380 getCommonPrefix (s:ss) = foldl common s ss
1381 where common s "" = ""
1383 common (c:cs) (d:ds)
1384 | c == d = c : common cs ds
1387 allExposedModules :: DynFlags -> [ModuleName]
1388 allExposedModules dflags
1389 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1391 pkg_db = pkgIdMap (pkgState dflags)
1393 completeCmd = completeNone
1394 completeMacro = completeNone
1395 completeIdentifier = completeNone
1396 completeModule = completeNone
1397 completeHomeModule = completeNone
1398 completeSetOptions = completeNone
1399 completeFilename = completeNone
1400 completeHomeModuleOrFile=completeNone
1401 completeBkpt = completeNone
1404 -- ---------------------------------------------------------------------------
1405 -- User code exception handling
1407 -- This is the exception handler for exceptions generated by the
1408 -- user's code and exceptions coming from children sessions;
1409 -- it normally just prints out the exception. The
1410 -- handler must be recursive, in case showing the exception causes
1411 -- more exceptions to be raised.
1413 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1414 -- raising another exception. We therefore don't put the recursive
1415 -- handler arond the flushing operation, so if stderr is closed
1416 -- GHCi will just die gracefully rather than going into an infinite loop.
1417 handler :: Exception -> GHCi Bool
1419 handler exception = do
1421 io installSignalHandlers
1422 ghciHandle handler (showException exception >> return False)
1424 showException (DynException dyn) =
1425 case fromDynamic dyn of
1426 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
1427 Just Interrupted -> io (putStrLn "Interrupted.")
1428 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
1429 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1430 Just other_ghc_ex -> io (print other_ghc_ex)
1432 showException other_exception
1433 = io (putStrLn ("*** Exception: " ++ show other_exception))
1435 -----------------------------------------------------------------------------
1436 -- recursive exception handlers
1438 -- Don't forget to unblock async exceptions in the handler, or if we're
1439 -- in an exception loop (eg. let a = error a in a) the ^C exception
1440 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1442 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1443 ghciHandle h (GHCi m) = GHCi $ \s ->
1444 Exception.catch (m s)
1445 (\e -> unGHCi (ghciUnblock (h e)) s)
1447 ghciUnblock :: GHCi a -> GHCi a
1448 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1451 -- ----------------------------------------------------------------------------
1454 expandPath :: String -> GHCi String
1456 case dropWhile isSpace path of
1458 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1459 return (tilde ++ '/':d)
1463 wantInterpretedModule :: String -> GHCi Module
1464 wantInterpretedModule str = do
1465 session <- getSession
1466 modl <- lookupModule str
1467 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1468 when (not is_interpreted) $
1469 throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1472 wantNameFromInterpretedModule noCanDo str and_then = do
1473 session <- getSession
1474 names <- io $ GHC.parseName session str
1478 let modl = GHC.nameModule n
1479 if not (GHC.isExternalName n)
1480 then noCanDo n $ ppr n <>
1481 text " is not defined in an interpreted module"
1483 is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1484 if not is_interpreted
1485 then noCanDo n $ text "module " <> ppr modl <>
1486 text " is not interpreted"
1489 -- ----------------------------------------------------------------------------
1490 -- Windows console setup
1492 setUpConsole :: IO ()
1494 #ifdef mingw32_HOST_OS
1495 -- On Windows we need to set a known code page, otherwise the characters
1496 -- we read from the console will be be in some strange encoding, and
1497 -- similarly for characters we write to the console.
1499 -- At the moment, GHCi pretends all input is Latin-1. In the
1500 -- future we should support UTF-8, but for now we set the code pages
1503 -- It seems you have to set the font in the console window to
1504 -- a Unicode font in order for output to work properly,
1505 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1506 -- (see MSDN for SetConsoleOutputCP()).
1508 setConsoleCP 28591 -- ISO Latin-1
1509 setConsoleOutputCP 28591 -- ISO Latin-1
1513 -- -----------------------------------------------------------------------------
1514 -- commands for debugger
1516 sprintCmd = pprintCommand False False
1517 printCmd = pprintCommand True False
1518 forceCmd = pprintCommand False True
1520 pprintCommand bind force str = do
1521 session <- getSession
1522 io $ pprintClosureCommand session bind force str
1524 stepCmd :: String -> GHCi ()
1525 stepCmd [] = doContinue GHC.SingleStep
1526 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1528 traceCmd :: String -> GHCi ()
1529 traceCmd [] = doContinue GHC.RunAndLogSteps
1530 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1532 continueCmd :: String -> GHCi ()
1533 continueCmd = noArgs $ doContinue GHC.RunToCompletion
1535 doContinue :: SingleStep -> GHCi ()
1536 doContinue step = do
1537 session <- getSession
1538 runResult <- io $ GHC.resume session step
1539 afterRunStmt runResult
1542 abandonCmd :: String -> GHCi ()
1543 abandonCmd = noArgs $ do
1545 b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1546 when (not b) $ io $ putStrLn "There is no computation running."
1549 deleteCmd :: String -> GHCi ()
1550 deleteCmd argLine = do
1551 deleteSwitch $ words argLine
1553 deleteSwitch :: [String] -> GHCi ()
1555 io $ putStrLn "The delete command requires at least one argument."
1556 -- delete all break points
1557 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1558 deleteSwitch idents = do
1559 mapM_ deleteOneBreak idents
1561 deleteOneBreak :: String -> GHCi ()
1563 | all isDigit str = deleteBreak (read str)
1564 | otherwise = return ()
1566 historyCmd :: String -> GHCi ()
1568 | null arg = history 20
1569 | all isDigit arg = history (read arg)
1570 | otherwise = io $ putStrLn "Syntax: :history [num]"
1574 resumes <- io $ GHC.getResumeContext s
1576 [] -> io $ putStrLn "Not stopped at a breakpoint"
1578 let hist = GHC.resumeHistory r
1579 (took,rest) = splitAt num hist
1580 spans <- mapM (io . GHC.getHistorySpan s) took
1581 let nums = map (printf "-%-3d:") [(1::Int)..]
1582 printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
1583 io $ putStrLn $ if null rest then "<end of history>" else "..."
1585 backCmd :: String -> GHCi ()
1586 backCmd = noArgs $ do
1588 (names, ix, span) <- io $ GHC.back s
1589 printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1590 printTypeOfNames s names
1591 -- run the command set with ":set stop <cmd>"
1593 enqueueCommands [stop st]
1595 forwardCmd :: String -> GHCi ()
1596 forwardCmd = noArgs $ do
1598 (names, ix, span) <- io $ GHC.forward s
1599 printForUser $ (if (ix == 0)
1600 then ptext SLIT("Stopped at")
1601 else ptext SLIT("Logged breakpoint at")) <+> ppr span
1602 printTypeOfNames s names
1603 -- run the command set with ":set stop <cmd>"
1605 enqueueCommands [stop st]
1607 -- handle the "break" command
1608 breakCmd :: String -> GHCi ()
1609 breakCmd argLine = do
1610 session <- getSession
1611 breakSwitch session $ words argLine
1613 breakSwitch :: Session -> [String] -> GHCi ()
1614 breakSwitch _session [] = do
1615 io $ putStrLn "The break command requires at least one argument."
1616 breakSwitch session args@(arg1:rest)
1617 | looksLikeModuleName arg1 = do
1618 mod <- wantInterpretedModule arg1
1619 breakByModule session mod rest
1620 | all isDigit arg1 = do
1621 (toplevel, _) <- io $ GHC.getContext session
1623 (mod : _) -> breakByModuleLine mod (read arg1) rest
1625 io $ putStrLn "Cannot find default module for breakpoint."
1626 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1627 | otherwise = do -- try parsing it as an identifier
1628 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1629 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1630 if GHC.isGoodSrcLoc loc
1631 then findBreakAndSet (GHC.nameModule name) $
1632 findBreakByCoord (Just (GHC.srcLocFile loc))
1633 (GHC.srcLocLine loc,
1635 else noCanDo name $ text "can't find its location: " <> ppr loc
1637 noCanDo n why = printForUser $
1638 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1640 breakByModule :: Session -> Module -> [String] -> GHCi ()
1641 breakByModule session mod args@(arg1:rest)
1642 | all isDigit arg1 = do -- looks like a line number
1643 breakByModuleLine mod (read arg1) rest
1644 | otherwise = io $ putStrLn "Invalid arguments to :break"
1646 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1647 breakByModuleLine mod line args
1648 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1649 | [col] <- args, all isDigit col =
1650 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1651 | otherwise = io $ putStrLn "Invalid arguments to :break"
1653 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1654 findBreakAndSet mod lookupTickTree = do
1655 tickArray <- getTickArray mod
1656 (breakArray, _) <- getModBreak mod
1657 case lookupTickTree tickArray of
1658 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1659 Just (tick, span) -> do
1660 success <- io $ setBreakFlag True breakArray tick
1661 session <- getSession
1665 recordBreak $ BreakLocation
1672 text "Breakpoint " <> ppr nm <>
1674 then text " was already set at " <> ppr span
1675 else text " activated at " <> ppr span
1677 printForUser $ text "Breakpoint could not be activated at"
1680 -- When a line number is specified, the current policy for choosing
1681 -- the best breakpoint is this:
1682 -- - the leftmost complete subexpression on the specified line, or
1683 -- - the leftmost subexpression starting on the specified line, or
1684 -- - the rightmost subexpression enclosing the specified line
1686 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1687 findBreakByLine line arr
1688 | not (inRange (bounds arr) line) = Nothing
1690 listToMaybe (sortBy leftmost_largest complete) `mplus`
1691 listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
1692 listToMaybe (sortBy rightmost ticks)
1696 starts_here = [ tick | tick@(nm,span) <- ticks,
1697 GHC.srcSpanStartLine span == line ]
1699 (complete,incomplete) = partition ends_here starts_here
1700 where ends_here (nm,span) = GHC.srcSpanEndLine span == line
1702 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1703 -> Maybe (BreakIndex,SrcSpan)
1704 findBreakByCoord mb_file (line, col) arr
1705 | not (inRange (bounds arr) line) = Nothing
1707 listToMaybe (sortBy rightmost contains) `mplus`
1708 listToMaybe (sortBy leftmost_smallest after_here)
1712 -- the ticks that span this coordinate
1713 contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
1714 is_correct_file span ]
1716 is_correct_file span
1717 | Just f <- mb_file = GHC.srcSpanFile span == f
1720 after_here = [ tick | tick@(nm,span) <- ticks,
1721 GHC.srcSpanStartLine span == line,
1722 GHC.srcSpanStartCol span >= col ]
1725 leftmost_smallest (_,a) (_,b) = a `compare` b
1726 leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
1728 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
1729 rightmost (_,a) (_,b) = b `compare` a
1731 spans :: SrcSpan -> (Int,Int) -> Bool
1732 spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
1733 where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
1735 -- for now, use ANSI bold on Unixy systems. On Windows, we add a line
1736 -- of carets under the active expression instead. The Windows console
1737 -- doesn't support ANSI escape sequences, and most Unix terminals
1738 -- (including xterm) do, so this is a reasonable guess until we have a
1739 -- proper termcap/terminfo library.
1740 #if !defined(mingw32_TARGET_OS)
1746 start_bold = BS.pack "\ESC[1m"
1747 end_bold = BS.pack "\ESC[0m"
1749 listCmd :: String -> GHCi ()
1751 mb_span <- getCurrentBreakSpan
1753 Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
1754 Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
1755 | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
1756 listCmd str = list2 (words str)
1758 list2 [arg] | all isDigit arg = do
1759 session <- getSession
1760 (toplevel, _) <- io $ GHC.getContext session
1762 [] -> io $ putStrLn "No module to list"
1763 (mod : _) -> listModuleLine mod (read arg)
1764 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
1765 mod <- wantInterpretedModule arg1
1766 listModuleLine mod (read arg2)
1768 wantNameFromInterpretedModule noCanDo arg $ \name -> do
1769 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1770 if GHC.isGoodSrcLoc loc
1772 tickArray <- getTickArray (GHC.nameModule name)
1773 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
1774 (GHC.srcLocLine loc, GHC.srcLocCol loc)
1777 Nothing -> io $ listAround (GHC.srcLocSpan loc) False
1778 Just (_,span) -> io $ listAround span False
1780 noCanDo name $ text "can't find its location: " <>
1783 noCanDo n why = printForUser $
1784 text "cannot list source code for " <> ppr n <> text ": " <> why
1786 io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
1788 listModuleLine :: Module -> Int -> GHCi ()
1789 listModuleLine modl line = do
1790 session <- getSession
1791 graph <- io (GHC.getModuleGraph session)
1792 let this = filter ((== modl) . GHC.ms_mod) graph
1794 [] -> panic "listModuleLine"
1796 let filename = fromJust (ml_hs_file (GHC.ms_location summ))
1797 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
1798 io $ listAround (GHC.srcLocSpan loc) False
1800 -- | list a section of a source file around a particular SrcSpan.
1801 -- If the highlight flag is True, also highlight the span using
1802 -- start_bold/end_bold.
1803 listAround span do_highlight = do
1804 contents <- BS.readFile (unpackFS file)
1806 lines = BS.split '\n' contents
1807 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
1808 drop (line1 - 1 - pad_before) $ lines
1809 fst_line = max 1 (line1 - pad_before)
1810 line_nos = [ fst_line .. ]
1812 highlighted | do_highlight = zipWith highlight line_nos these_lines
1813 | otherwise = these_lines
1815 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
1816 prefixed = zipWith BS.append bs_line_nos highlighted
1818 BS.putStrLn (BS.join (BS.pack "\n") prefixed)
1820 file = GHC.srcSpanFile span
1821 line1 = GHC.srcSpanStartLine span
1822 col1 = GHC.srcSpanStartCol span
1823 line2 = GHC.srcSpanEndLine span
1824 col2 = GHC.srcSpanEndCol span
1826 pad_before | line1 == 1 = 0
1830 highlight | do_bold = highlight_bold
1831 | otherwise = highlight_carets
1833 highlight_bold no line
1834 | no == line1 && no == line2
1835 = let (a,r) = BS.splitAt col1 line
1836 (b,c) = BS.splitAt (col2-col1) r
1838 BS.concat [a,start_bold,b,end_bold,c]
1840 = let (a,b) = BS.splitAt col1 line in
1841 BS.concat [a, start_bold, b]
1843 = let (a,b) = BS.splitAt col2 line in
1844 BS.concat [a, end_bold, b]
1847 highlight_carets no line
1848 | no == line1 && no == line2
1849 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1850 BS.replicate (col2-col1) '^']
1852 = BS.concat [line, nl, indent, BS.replicate col1 ' ',
1853 BS.replicate (BS.length line-col1) '^']
1855 = BS.concat [line, nl, indent, BS.replicate col2 '^']
1858 indent = BS.pack " "
1859 nl = BS.singleton '\n'
1861 -- --------------------------------------------------------------------------
1864 getTickArray :: Module -> GHCi TickArray
1865 getTickArray modl = do
1867 let arrmap = tickarrays st
1868 case lookupModuleEnv arrmap modl of
1869 Just arr -> return arr
1871 (breakArray, ticks) <- getModBreak modl
1872 let arr = mkTickArray (assocs ticks)
1873 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1876 discardTickArrays :: GHCi ()
1877 discardTickArrays = do
1879 setGHCiState st{tickarrays = emptyModuleEnv}
1881 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1883 = accumArray (flip (:)) [] (1, max_line)
1884 [ (line, (nm,span)) | (nm,span) <- ticks,
1885 line <- srcSpanLines span ]
1887 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
1888 srcSpanLines span = [ GHC.srcSpanStartLine span ..
1889 GHC.srcSpanEndLine span ]
1891 lookupModule :: String -> GHCi Module
1892 lookupModule modName
1893 = do session <- getSession
1894 io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1896 -- don't reset the counter back to zero?
1897 discardActiveBreakPoints :: GHCi ()
1898 discardActiveBreakPoints = do
1900 mapM (turnOffBreak.snd) (breaks st)
1901 setGHCiState $ st { breaks = [] }
1903 deleteBreak :: Int -> GHCi ()
1904 deleteBreak identity = do
1906 let oldLocations = breaks st
1907 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
1909 then printForUser (text "Breakpoint" <+> ppr identity <+>
1910 text "does not exist")
1912 mapM (turnOffBreak.snd) this
1913 setGHCiState $ st { breaks = rest }
1915 turnOffBreak loc = do
1916 (arr, _) <- getModBreak (breakModule loc)
1917 io $ setBreakFlag False arr (breakTick loc)
1919 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
1920 getModBreak mod = do
1921 session <- getSession
1922 Just mod_info <- io $ GHC.getModuleInfo session mod
1923 let modBreaks = GHC.modInfoModBreaks mod_info
1924 let array = GHC.modBreaks_flags modBreaks
1925 let ticks = GHC.modBreaks_locs modBreaks
1926 return (array, ticks)
1928 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
1929 setBreakFlag toggle array index
1930 | toggle = GHC.setBreakOn array index
1931 | otherwise = GHC.setBreakOff array index