1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5 -----------------------------------------------------------------------------
7 -- GHC Interactive User Interface
9 -- (c) The GHC Team 2005-2006
11 -----------------------------------------------------------------------------
13 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
15 #include "HsVersions.h"
17 import qualified GhciMonad
18 import GhciMonad hiding (runStmt)
23 import qualified GHC hiding (resume, runStmt)
24 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
26 BreakIndex, Resume, SingleStep,
27 Ghc, handleSourceError )
32 -- import PackageConfig
35 import HscTypes ( implicitTyThings, handleFlagWarnings )
36 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
37 import Outputable hiding (printForUser, printForUserPartWay)
38 import Module -- for ModuleEnv
42 -- Other random utilities
45 import BasicTypes hiding (isTopLevel)
46 import Panic hiding (showException)
52 import Maybes ( orElse, expectJust )
57 #ifndef mingw32_HOST_OS
58 import System.Posix hiding (getEnv)
60 import qualified System.Win32
63 import System.Console.Haskeline as Haskeline
64 import qualified System.Console.Haskeline.Encoding as Encoding
65 import Control.Monad.Trans
69 import Exception hiding (catch, block, unblock)
71 -- import Control.Concurrent
73 import System.FilePath
74 import qualified Data.ByteString.Char8 as BS
78 import System.Environment
79 import System.Exit ( exitWith, ExitCode(..) )
80 import System.Directory
82 import System.IO.Error as IO
85 import Control.Monad as Monad
88 import GHC.Exts ( unsafeCoerce# )
90 #if __GLASGOW_HASKELL__ >= 611
91 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
92 import GHC.IO.Handle ( hFlushAll )
94 import GHC.IOBase ( IOErrorType(InvalidArgument) )
99 import Data.IORef ( IORef, readIORef, writeIORef )
101 -----------------------------------------------------------------------------
103 ghciWelcomeMsg :: String
104 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
105 ": http://www.haskell.org/ghc/ :? for help"
107 cmdName :: Command -> String
110 GLOBAL_VAR(macros_ref, [], [Command])
112 builtin_commands :: [Command]
114 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
115 ("?", keepGoing help, noCompletion),
116 ("add", keepGoingPaths addModule, completeFilename),
117 ("abandon", keepGoing abandonCmd, noCompletion),
118 ("break", keepGoing breakCmd, completeIdentifier),
119 ("back", keepGoing backCmd, noCompletion),
120 ("browse", keepGoing' (browseCmd False), completeModule),
121 ("browse!", keepGoing' (browseCmd True), completeModule),
122 ("cd", keepGoing' changeDirectory, completeFilename),
123 ("check", keepGoing' checkModule, completeHomeModule),
124 ("continue", keepGoing continueCmd, noCompletion),
125 ("cmd", keepGoing cmdCmd, completeExpression),
126 ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
127 ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
128 ("def", keepGoing (defineMacro False), completeExpression),
129 ("def!", keepGoing (defineMacro True), completeExpression),
130 ("delete", keepGoing deleteCmd, noCompletion),
131 ("edit", keepGoing editFile, completeFilename),
132 ("etags", keepGoing createETagsFileCmd, completeFilename),
133 ("force", keepGoing forceCmd, completeExpression),
134 ("forward", keepGoing forwardCmd, noCompletion),
135 ("help", keepGoing help, noCompletion),
136 ("history", keepGoing historyCmd, noCompletion),
137 ("info", keepGoing' info, completeIdentifier),
138 ("kind", keepGoing' kindOfType, completeIdentifier),
139 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
140 ("list", keepGoing' listCmd, noCompletion),
141 ("module", keepGoing setContext, completeModule),
142 ("main", keepGoing runMain, completeFilename),
143 ("print", keepGoing printCmd, completeExpression),
144 ("quit", quit, noCompletion),
145 ("reload", keepGoing' reloadModule, noCompletion),
146 ("run", keepGoing runRun, completeFilename),
147 ("set", keepGoing setCmd, completeSetOptions),
148 ("show", keepGoing showCmd, completeShowOptions),
149 ("sprint", keepGoing sprintCmd, completeExpression),
150 ("step", keepGoing stepCmd, completeIdentifier),
151 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
152 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
153 ("type", keepGoing' typeOfExpr, completeExpression),
154 ("trace", keepGoing traceCmd, completeExpression),
155 ("undef", keepGoing undefineMacro, completeMacro),
156 ("unset", keepGoing unsetOptions, completeSetOptions)
160 -- We initialize readline (in the interactiveUI function) to use
161 -- word_break_chars as the default set of completion word break characters.
162 -- This can be overridden for a particular command (for example, filename
163 -- expansion shouldn't consider '/' to be a word break) by setting the third
164 -- entry in the Command tuple above.
166 -- NOTE: in order for us to override the default correctly, any custom entry
167 -- must be a SUBSET of word_break_chars.
168 word_break_chars :: String
169 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
170 specials = "(),;[]`{}"
172 in spaces ++ specials ++ symbols
174 flagWordBreakChars :: String
175 flagWordBreakChars = " \t\n"
178 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
179 keepGoing a str = keepGoing' (lift . a) str
181 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
182 keepGoing' a str = a str >> return False
184 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
186 = do case toArgs str of
187 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
191 shortHelpText :: String
192 shortHelpText = "use :? for help.\n"
196 " Commands available from the prompt:\n" ++
198 " <statement> evaluate/run <statement>\n" ++
199 " : repeat last command\n" ++
200 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
201 " :add [*]<module> ... add module(s) to the current target set\n" ++
202 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
203 " (!: more details; *: all top-level names)\n" ++
204 " :cd <dir> change directory to <dir>\n" ++
205 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
206 " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
207 " (!: use regex instead of line number)\n" ++
208 " :def <cmd> <expr> define a command :<cmd>\n" ++
209 " :edit <file> edit file\n" ++
210 " :edit edit last module\n" ++
211 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
212 " :help, :? display this list of commands\n" ++
213 " :info [<name> ...] display information about the given names\n" ++
214 " :kind <type> show the kind of <type>\n" ++
215 " :load [*]<module> ... load module(s) and their dependents\n" ++
216 " :main [<arguments> ...] run the main function with the given arguments\n" ++
217 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
218 " :quit exit GHCi\n" ++
219 " :reload reload the current module set\n" ++
220 " :run function [<arguments> ...] run the function with the given arguments\n" ++
221 " :type <expr> show the type of <expr>\n" ++
222 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
223 " :!<command> run the shell command <command>\n" ++
225 " -- Commands for debugging:\n" ++
227 " :abandon at a breakpoint, abandon current computation\n" ++
228 " :back go back in the history (after :trace)\n" ++
229 " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
230 " :break <name> set a breakpoint on the specified function\n" ++
231 " :continue resume after a breakpoint\n" ++
232 " :delete <number> delete the specified breakpoint\n" ++
233 " :delete * delete all breakpoints\n" ++
234 " :force <expr> print <expr>, forcing unevaluated parts\n" ++
235 " :forward go forward in the history (after :back)\n" ++
236 " :history [<n>] after :trace, show the execution history\n" ++
237 " :list show the source code around current breakpoint\n" ++
238 " :list identifier show the source code for <identifier>\n" ++
239 " :list [<module>] <line> show the source code around line number <line>\n" ++
240 " :print [<name> ...] prints a value without forcing its computation\n" ++
241 " :sprint [<name> ...] simplifed version of :print\n" ++
242 " :step single-step after stopping at a breakpoint\n"++
243 " :step <expr> single-step into <expr>\n"++
244 " :steplocal single-step within the current top-level binding\n"++
245 " :stepmodule single-step restricted to the current module\n"++
246 " :trace trace after stopping at a breakpoint\n"++
247 " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
250 " -- Commands for changing settings:\n" ++
252 " :set <option> ... set options\n" ++
253 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
254 " :set prog <progname> set the value returned by System.getProgName\n" ++
255 " :set prompt <prompt> set the prompt used in GHCi\n" ++
256 " :set editor <cmd> set the command used for :edit\n" ++
257 " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
258 " :unset <option> ... unset options\n" ++
260 " Options for ':set' and ':unset':\n" ++
262 " +r revert top-level expressions after each evaluation\n" ++
263 " +s print timing/memory stats after each evaluation\n" ++
264 " +t print type after evaluation\n" ++
265 " -<flags> most GHC command line flags can also be set here\n" ++
266 " (eg. -v2, -fglasgow-exts, etc.)\n" ++
267 " for GHCi-specific flags, see User's Guide,\n"++
268 " Flag reference, Interactive-mode options\n" ++
270 " -- Commands for displaying information:\n" ++
272 " :show bindings show the current bindings made at the prompt\n" ++
273 " :show breaks show the active breakpoints\n" ++
274 " :show context show the breakpoint context\n" ++
275 " :show modules show the currently loaded modules\n" ++
276 " :show packages show the currently active package flags\n" ++
277 " :show languages show the currently active language flags\n" ++
278 " :show <setting> show value of <setting>, which is one of\n" ++
279 " [args, prog, prompt, editor, stop]\n" ++
282 findEditor :: IO String
287 win <- System.Win32.getWindowsDirectory
288 return (win </> "notepad.exe")
293 foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
295 interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
297 interactiveUI srcs maybe_exprs = do
298 -- although GHCi compiles with -prof, it is not usable: the byte-code
299 -- compiler and interpreter don't work with profiling. So we check for
300 -- this up front and emit a helpful error message (#2197)
301 i <- liftIO $ isProfiled
303 ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
305 -- HACK! If we happen to get into an infinite loop (eg the user
306 -- types 'let x=x in x' at the prompt), then the thread will block
307 -- on a blackhole, and become unreachable during GC. The GC will
308 -- detect that it is unreachable and send it the NonTermination
309 -- exception. However, since the thread is unreachable, everything
310 -- it refers to might be finalized, including the standard Handles.
311 -- This sounds like a bug, but we don't have a good solution right
313 _ <- liftIO $ newStablePtr stdin
314 _ <- liftIO $ newStablePtr stdout
315 _ <- liftIO $ newStablePtr stderr
317 -- Initialise buffering for the *interpreted* I/O system
320 liftIO $ when (isNothing maybe_exprs) $ do
321 -- Only for GHCi (not runghc and ghc -e):
323 -- Turn buffering off for the compiled program's stdout/stderr
325 -- Turn buffering off for GHCi's stdout
327 hSetBuffering stdout NoBuffering
328 -- We don't want the cmd line to buffer any input that might be
329 -- intended for the program, so unbuffer stdin.
330 hSetBuffering stdin NoBuffering
331 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611
332 -- On Unix, stdin will use the locale encoding. The IO library
333 -- doesn't do this on Windows (yet), so for now we use UTF-8,
334 -- for consistency with GHC 6.10 and to make the tests work.
335 hSetEncoding stdin utf8
338 -- initial context is just the Prelude
339 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
340 GHC.setContext [] [prel_mod]
342 default_editor <- liftIO $ findEditor
344 startGHCi (runGHCi srcs maybe_exprs)
345 GHCiState{ progname = "<interactive>",
349 editor = default_editor,
350 -- session = session,
355 tickarrays = emptyModuleEnv,
356 last_command = Nothing,
359 ghc_e = isJust maybe_exprs
364 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
365 withGhcAppData right left = do
366 either_dir <- IO.try (getAppUserDataDirectory "ghc")
368 Right dir -> right dir
371 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
372 runGHCi paths maybe_exprs = do
374 read_dot_files = not opt_IgnoreDotGhci
376 current_dir = return (Just ".ghci")
378 app_user_dir = io $ withGhcAppData
379 (\dir -> return (Just (dir </> "ghci.conf")))
383 either_dir <- io $ IO.try (getEnv "HOME")
385 Right home -> return (Just (home </> ".ghci"))
388 sourceConfigFile :: FilePath -> GHCi ()
389 sourceConfigFile file = do
390 exists <- io $ doesFileExist file
392 dir_ok <- io $ checkPerms (getDirectory file)
393 file_ok <- io $ checkPerms file
394 when (dir_ok && file_ok) $ do
395 either_hdl <- io $ IO.try (openFile file ReadMode)
398 -- NOTE: this assumes that runInputT won't affect the terminal;
399 -- can we assume this will always be the case?
400 -- This would be a good place for runFileInputT.
401 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
402 runCommands $ fileLoop hdl
404 getDirectory f = case takeDirectory f of "" -> "."; d -> d
406 when (read_dot_files) $ do
407 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
408 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
409 mapM_ sourceConfigFile (nub cfgs)
410 -- nub, because we don't want to read .ghci twice if the
413 -- Perform a :load for files given on the GHCi command line
414 -- When in -e mode, if the load fails then we want to stop
415 -- immediately rather than going on to evaluate the expression.
416 when (not (null paths)) $ do
417 ok <- ghciHandle (\e -> do showException e; return Failed) $
418 -- TODO: this is a hack.
419 runInputTWithPrefs defaultPrefs defaultSettings $ do
420 let (filePaths, phases) = unzip paths
421 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
422 loadModule (zip filePaths' phases)
423 when (isJust maybe_exprs && failed ok) $
424 io (exitWith (ExitFailure 1))
426 -- if verbosity is greater than 0, or we are connected to a
427 -- terminal, display the prompt in the interactive loop.
428 is_tty <- io (hIsTerminalDevice stdin)
429 dflags <- getDynFlags
430 let show_prompt = verbosity dflags > 0 || is_tty
435 -- enter the interactive loop
436 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
438 -- just evaluate the expression we were given
439 enqueueCommands exprs
440 let handle e = do st <- getGHCiState
441 -- flush the interpreter's stdout/stderr on exit (#3890)
443 -- Jump through some hoops to get the
444 -- current progname in the exception text:
445 -- <progname>: <exception>
446 io $ withProgName (progname st)
447 -- this used to be topHandlerFastExit, see #2228
449 runInputTWithPrefs defaultPrefs defaultSettings $ do
450 runCommands' handle (return Nothing)
453 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
455 runGHCiInput :: InputT GHCi a -> GHCi a
457 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
459 let settings = setComplete ghciCompleteWord
460 $ defaultSettings {historyFile = histFile}
463 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
464 nextInputLine show_prompt is_tty
466 prompt <- if show_prompt then lift mkPrompt else return ""
469 when show_prompt $ lift mkPrompt >>= liftIO . putStr
472 -- NOTE: We only read .ghci files if they are owned by the current user,
473 -- and aren't world writable. Otherwise, we could be accidentally
474 -- running code planted by a malicious third party.
476 -- Furthermore, We only read ./.ghci if . is owned by the current user
477 -- and isn't writable by anyone else. I think this is sufficient: we
478 -- don't need to check .. and ../.. etc. because "." always refers to
479 -- the same directory while a process is running.
481 checkPerms :: String -> IO Bool
482 #ifdef mingw32_HOST_OS
487 handleIO (\_ -> return False) $ do
488 st <- getFileStatus name
490 if fileOwner st /= me then do
491 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
494 let mode = fileMode st
495 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
496 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
498 putStrLn $ "*** WARNING: " ++ name ++
499 " is writable by someone else, IGNORING!"
504 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
506 l <- liftIO $ IO.try $ hGetLine hdl
508 Left e | isEOFError e -> return Nothing
509 | InvalidArgument <- etype -> return Nothing
510 | otherwise -> liftIO $ ioError e
511 where etype = ioeGetErrorType e
512 -- treat InvalidArgument in the same way as EOF:
513 -- this can happen if the user closed stdin, or
514 -- perhaps did getContents which closes stdin at
516 Right l -> return (Just l)
518 mkPrompt :: GHCi String
520 (toplevs,exports) <- GHC.getContext
521 resumes <- GHC.getResumeContext
522 -- st <- getGHCiState
528 let ix = GHC.resumeHistoryIx r
530 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
532 let hist = GHC.resumeHistory r !! (ix-1)
533 span <- GHC.getHistorySpan hist
534 return (brackets (ppr (negate ix) <> char ':'
535 <+> ppr span) <> space)
537 dots | _:rs <- resumes, not (null rs) = text "... "
544 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
545 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
546 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
547 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
548 hsep (map (ppr . GHC.moduleName) exports)
550 deflt_prompt = dots <> context_bit <> modules_bit
552 f ('%':'s':xs) = deflt_prompt <> f xs
553 f ('%':'%':xs) = char '%' <> f xs
554 f (x:xs) = char x <> f xs
558 return (showSDoc (f (prompt st)))
561 queryQueue :: GHCi (Maybe String)
566 c:cs -> do setGHCiState st{ cmdqueue = cs }
569 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
570 runCommands = runCommands' handler
572 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
573 -> InputT GHCi (Maybe String) -> InputT GHCi ()
574 runCommands' eh getCmd = do
575 b <- handleGhcException (\e -> case e of
576 Interrupted -> return False
577 _other -> liftIO (print e) >> return True)
578 (runOneCommand eh getCmd)
579 if b then return () else runCommands' eh getCmd
581 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
583 runOneCommand eh getCmd = do
584 mb_cmd <- noSpace (lift queryQueue)
585 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
587 Nothing -> return True
588 Just c -> ghciHandle (lift . eh) $
589 handleSourceError printErrorAndKeepGoing
592 printErrorAndKeepGoing err = do
593 GHC.printExceptionAndWarnings err
596 noSpace q = q >>= maybe (return Nothing)
597 (\c->case removeSpaces c of
599 ":{" -> multiLineCmd q
600 c -> return (Just c) )
602 st <- lift getGHCiState
604 lift $ setGHCiState st{ prompt = "%s| " }
605 mb_cmd <- collectCommand q ""
606 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
608 -- we can't use removeSpaces for the sublines here, so
609 -- multiline commands are somewhat more brittle against
610 -- fileformat errors (such as \r in dos input on unix),
611 -- we get rid of any extra spaces for the ":}" test;
612 -- we also avoid silent failure if ":}" is not found;
613 -- and since there is no (?) valid occurrence of \r (as
614 -- opposed to its String representation, "\r") inside a
615 -- ghci command, we replace any such with ' ' (argh:-(
616 collectCommand q c = q >>=
617 maybe (liftIO (ioError collectError))
618 (\l->if removeSpaces l == ":}"
619 then return (Just $ removeSpaces c)
620 else collectCommand q (c++map normSpace l))
621 where normSpace '\r' = ' '
623 -- QUESTION: is userError the one to use here?
624 collectError = userError "unterminated multiline command :{ .. :}"
625 doCommand (':' : cmd) = specialCommand cmd
626 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
629 enqueueCommands :: [String] -> GHCi ()
630 enqueueCommands cmds = do
632 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
635 runStmt :: String -> SingleStep -> GHCi Bool
637 | null (filter (not.isSpace) stmt) = return False
638 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
641 #if __GLASGOW_HASKELL__ >= 611
642 -- In the new IO library, read handles buffer data even if the Handle
643 -- is set to NoBuffering. This causes problems for GHCi where there
644 -- are really two stdin Handles. So we flush any bufferred data in
645 -- GHCi's stdin Handle here (only relevant if stdin is attached to
646 -- a file, otherwise the read buffer can't be flushed).
647 _ <- liftIO $ IO.try $ hFlushAll stdin
649 result <- GhciMonad.runStmt stmt step
650 afterRunStmt (const True) result
652 --afterRunStmt :: GHC.RunResult -> GHCi Bool
653 -- False <=> the statement failed to compile
654 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
655 afterRunStmt _ (GHC.RunException e) = throw e
656 afterRunStmt step_here run_result = do
657 resumes <- GHC.getResumeContext
659 GHC.RunOk names -> do
660 show_types <- isOptionSet ShowType
661 when show_types $ printTypeOfNames names
662 GHC.RunBreak _ names mb_info
663 | isNothing mb_info ||
664 step_here (GHC.resumeSpan $ head resumes) -> do
665 mb_id_loc <- toBreakIdAndLocation mb_info
666 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
668 then printStoppedAtBreakInfo (head resumes) names
669 else enqueueCommands [breakCmd]
670 -- run the command set with ":set stop <cmd>"
672 enqueueCommands [stop st]
674 | otherwise -> resume step_here GHC.SingleStep >>=
675 afterRunStmt step_here >> return ()
679 io installSignalHandlers
680 b <- isOptionSet RevertCAFs
683 return (case run_result of GHC.RunOk _ -> True; _ -> False)
685 toBreakIdAndLocation ::
686 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
687 toBreakIdAndLocation Nothing = return Nothing
688 toBreakIdAndLocation (Just info) = do
689 let mod = GHC.breakInfo_module info
690 nm = GHC.breakInfo_number info
692 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
693 breakModule loc == mod,
694 breakTick loc == nm ]
696 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
697 printStoppedAtBreakInfo resume names = do
698 printForUser $ ptext (sLit "Stopped at") <+>
699 ppr (GHC.resumeSpan resume)
700 -- printTypeOfNames session names
701 let namesSorted = sortBy compareNames names
702 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
703 docs <- pprTypeAndContents [id | AnId id <- tythings]
704 printForUserPartWay docs
706 printTypeOfNames :: [Name] -> GHCi ()
707 printTypeOfNames names
708 = mapM_ (printTypeOfName ) $ sortBy compareNames names
710 compareNames :: Name -> Name -> Ordering
711 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
712 where compareWith n = (getOccString n, getSrcSpan n)
714 printTypeOfName :: Name -> GHCi ()
716 = do maybe_tything <- GHC.lookupName n
717 case maybe_tything of
719 Just thing -> printTyThing thing
722 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
724 specialCommand :: String -> InputT GHCi Bool
725 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
726 specialCommand str = do
727 let (cmd,rest) = break isSpace str
728 maybe_cmd <- lift $ lookupCommand cmd
730 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
732 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
736 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
740 lookupCommand :: String -> GHCi (MaybeCommand)
741 lookupCommand "" = do
743 case last_command st of
744 Just c -> return $ GotCommand c
745 Nothing -> return NoLastCommand
746 lookupCommand str = do
747 mc <- io $ lookupCommand' str
749 setGHCiState st{ last_command = mc }
751 Just c -> GotCommand c
752 Nothing -> BadCommand
754 lookupCommand' :: String -> IO (Maybe Command)
755 lookupCommand' ":" = return Nothing
756 lookupCommand' str' = do
757 macros <- readIORef macros_ref
758 let{ (str, cmds) = case str' of
759 ':' : rest -> (rest, builtin_commands)
760 _ -> (str', macros ++ builtin_commands) }
761 -- look for exact match first, then the first prefix match
762 return $ case [ c | c <- cmds, str == cmdName c ] of
764 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
768 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
769 getCurrentBreakSpan = do
770 resumes <- GHC.getResumeContext
774 let ix = GHC.resumeHistoryIx r
776 then return (Just (GHC.resumeSpan r))
778 let hist = GHC.resumeHistory r !! (ix-1)
779 span <- GHC.getHistorySpan hist
782 getCurrentBreakModule :: GHCi (Maybe Module)
783 getCurrentBreakModule = do
784 resumes <- GHC.getResumeContext
788 let ix = GHC.resumeHistoryIx r
790 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
792 let hist = GHC.resumeHistory r !! (ix-1)
793 return $ Just $ GHC.getHistoryModule hist
795 -----------------------------------------------------------------------------
798 noArgs :: GHCi () -> String -> GHCi ()
800 noArgs _ _ = io $ putStrLn "This command takes no arguments"
802 help :: String -> GHCi ()
803 help _ = io (putStr helpText)
805 info :: String -> InputT GHCi ()
806 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
807 info s = handleSourceError GHC.printExceptionAndWarnings $ do
808 { let names = words s
809 ; dflags <- getDynFlags
810 ; let pefas = dopt Opt_PrintExplicitForalls dflags
811 ; mapM_ (infoThing pefas) names }
813 infoThing pefas str = do
814 names <- GHC.parseName str
815 mb_stuffs <- mapM GHC.getInfo names
816 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
817 unqual <- GHC.getPrintUnqual
818 outputStrLn $ showSDocForUser unqual $
819 vcat (intersperse (text "") $
820 map (pprInfo pefas) filtered)
822 -- Filter out names whose parent is also there Good
823 -- example is '[]', which is both a type and data
824 -- constructor in the same type
825 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
826 filterOutChildren get_thing xs
827 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
829 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
831 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
832 pprInfo pefas (thing, fixity, insts)
833 = pprTyThingInContextLoc pefas thing
834 $$ show_fixity fixity
835 $$ vcat (map GHC.pprInstance insts)
838 | fix == GHC.defaultFixity = empty
839 | otherwise = ppr fix <+> ppr (GHC.getName thing)
841 runMain :: String -> GHCi ()
842 runMain s = case toArgs s of
843 Left err -> io (hPutStrLn stderr err)
845 do dflags <- getDynFlags
846 case mainFunIs dflags of
847 Nothing -> doWithArgs args "main"
848 Just f -> doWithArgs args f
850 runRun :: String -> GHCi ()
851 runRun s = case toCmdArgs s of
852 Left err -> io (hPutStrLn stderr err)
853 Right (cmd, args) -> doWithArgs args cmd
855 doWithArgs :: [String] -> String -> GHCi ()
856 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
857 show args ++ " (" ++ cmd ++ ")"]
859 addModule :: [FilePath] -> InputT GHCi ()
861 lift revertCAFs -- always revert CAFs on load/add.
862 files <- mapM expandPath files
863 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
864 -- remove old targets with the same id; e.g. for :add *M
865 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
866 mapM_ GHC.addTarget targets
867 prev_context <- GHC.getContext
868 ok <- trySuccess $ GHC.load LoadAllTargets
869 afterLoad ok False prev_context
871 changeDirectory :: String -> InputT GHCi ()
872 changeDirectory "" = do
873 -- :cd on its own changes to the user's home directory
874 either_dir <- liftIO $ IO.try getHomeDirectory
877 Right dir -> changeDirectory dir
878 changeDirectory dir = do
879 graph <- GHC.getModuleGraph
880 when (not (null graph)) $
881 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
882 prev_context <- GHC.getContext
884 _ <- GHC.load LoadAllTargets
885 lift $ setContextAfterLoad prev_context False []
886 GHC.workingDirectoryChanged
887 dir <- expandPath dir
888 liftIO $ setCurrentDirectory dir
890 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
892 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
896 editFile :: String -> GHCi ()
898 do file <- if null str then chooseEditFile else return str
902 $ ghcError (CmdLineError "editor not set, use :set editor")
903 _ <- io $ system (cmd ++ ' ':file)
906 -- The user didn't specify a file so we pick one for them.
907 -- Our strategy is to pick the first module that failed to load,
908 -- or otherwise the first target.
910 -- XXX: Can we figure out what happened if the depndecy analysis fails
911 -- (e.g., because the porgrammeer mistyped the name of a module)?
912 -- XXX: Can we figure out the location of an error to pass to the editor?
913 -- XXX: if we could figure out the list of errors that occured during the
914 -- last load/reaload, then we could start the editor focused on the first
916 chooseEditFile :: GHCi String
918 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
920 graph <- GHC.getModuleGraph
921 failed_graph <- filterM hasFailed graph
922 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
924 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
927 case pick (order failed_graph) of
928 Just file -> return file
930 do targets <- GHC.getTargets
931 case msum (map fromTarget targets) of
932 Just file -> return file
933 Nothing -> ghcError (CmdLineError "No files to edit.")
935 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
936 fromTarget _ = Nothing -- when would we get a module target?
938 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
939 defineMacro _ (':':_) =
940 io $ putStrLn "macro name cannot start with a colon"
941 defineMacro overwrite s = do
942 let (macro_name, definition) = break isSpace s
943 macros <- io (readIORef macros_ref)
944 let defined = map cmdName macros
947 then io $ putStrLn "no macros defined"
948 else io $ putStr ("the following macros are defined:\n" ++
951 if (not overwrite && macro_name `elem` defined)
952 then ghcError (CmdLineError
953 ("macro '" ++ macro_name ++ "' is already defined"))
956 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
958 -- give the expression a type signature, so we can be sure we're getting
959 -- something of the right type.
960 let new_expr = '(' : definition ++ ") :: String -> IO String"
962 -- compile the expression
963 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
964 hv <- GHC.compileExpr new_expr
965 io (writeIORef macros_ref --
966 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
968 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
970 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
971 -- make sure we force any exceptions in the result, while we are still
972 -- inside the exception handler for commands:
973 seqList str (return ())
974 enqueueCommands (lines str)
977 undefineMacro :: String -> GHCi ()
978 undefineMacro str = mapM_ undef (words str)
979 where undef macro_name = do
980 cmds <- io (readIORef macros_ref)
981 if (macro_name `notElem` map cmdName cmds)
982 then ghcError (CmdLineError
983 ("macro '" ++ macro_name ++ "' is not defined"))
985 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
987 cmdCmd :: String -> GHCi ()
989 let expr = '(' : str ++ ") :: IO String"
990 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
991 hv <- GHC.compileExpr expr
992 cmds <- io $ (unsafeCoerce# hv :: IO String)
993 enqueueCommands (lines cmds)
996 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
997 loadModule fs = timeIt (loadModule' fs)
999 loadModule_ :: [FilePath] -> InputT GHCi ()
1000 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1002 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1003 loadModule' files = do
1004 prev_context <- GHC.getContext
1008 lift discardActiveBreakPoints
1010 _ <- GHC.load LoadAllTargets
1012 let (filenames, phases) = unzip files
1013 exp_filenames <- mapM expandPath filenames
1014 let files' = zip exp_filenames phases
1015 targets <- mapM (uncurry GHC.guessTarget) files'
1017 -- NOTE: we used to do the dependency anal first, so that if it
1018 -- fails we didn't throw away the current set of modules. This would
1019 -- require some re-working of the GHC interface, so we'll leave it
1020 -- as a ToDo for now.
1022 GHC.setTargets targets
1023 doLoad False prev_context LoadAllTargets
1025 checkModule :: String -> InputT GHCi ()
1027 let modl = GHC.mkModuleName m
1028 prev_context <- GHC.getContext
1029 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1030 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1031 outputStrLn (showSDoc (
1032 case GHC.moduleInfo r of
1033 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1035 (local,global) = ASSERT( all isExternalName scope )
1036 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1038 (text "global names: " <+> ppr global) $$
1039 (text "local names: " <+> ppr local)
1042 afterLoad (successIf ok) False prev_context
1044 reloadModule :: String -> InputT GHCi ()
1046 prev_context <- GHC.getContext
1047 _ <- doLoad True prev_context $
1048 if null m then LoadAllTargets
1049 else LoadUpTo (GHC.mkModuleName m)
1052 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1053 doLoad retain_context prev_context howmuch = do
1054 -- turn off breakpoints before we load: we can't turn them off later, because
1055 -- the ModBreaks will have gone away.
1056 lift discardActiveBreakPoints
1057 ok <- trySuccess $ GHC.load howmuch
1058 afterLoad ok retain_context prev_context
1061 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1062 afterLoad ok retain_context prev_context = do
1063 lift revertCAFs -- always revert CAFs on load.
1064 lift discardTickArrays
1065 loaded_mod_summaries <- getLoadedModules
1066 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1067 loaded_mod_names = map GHC.moduleName loaded_mods
1068 modulesLoadedMsg ok loaded_mod_names
1070 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1073 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1074 setContextAfterLoad prev keep_ctxt [] = do
1075 prel_mod <- getPrelude
1076 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1077 setContextAfterLoad prev keep_ctxt ms = do
1078 -- load a target if one is available, otherwise load the topmost module.
1079 targets <- GHC.getTargets
1080 case [ m | Just m <- map (findTarget ms) targets ] of
1082 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1083 load_this (last graph')
1088 = case filter (`matches` t) ms of
1092 summary `matches` Target (TargetModule m) _ _
1093 = GHC.ms_mod_name summary == m
1094 summary `matches` Target (TargetFile f _) _ _
1095 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1099 load_this summary | m <- GHC.ms_mod summary = do
1100 b <- GHC.moduleIsInterpreted m
1101 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1103 prel_mod <- getPrelude
1104 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1106 -- | Keep any package modules (except Prelude) when changing the context.
1107 setContextKeepingPackageModules
1108 :: ([Module],[Module]) -- previous context
1109 -> Bool -- re-execute :module commands
1110 -> ([Module],[Module]) -- new context
1112 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1113 let (_,bs0) = prev_context
1114 prel_mod <- getPrelude
1115 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1116 let bs1 = if null as then nub (prel_mod : bs) else bs
1117 GHC.setContext as (nub (bs1 ++ pkg_modules))
1121 mapM_ (playCtxtCmd False) (remembered_ctx st)
1124 setGHCiState st{ remembered_ctx = [] }
1126 isHomeModule :: Module -> Bool
1127 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1129 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1130 modulesLoadedMsg ok mods = do
1131 dflags <- getDynFlags
1132 when (verbosity dflags > 0) $ do
1134 | null mods = text "none."
1135 | otherwise = hsep (
1136 punctuate comma (map ppr mods)) <> text "."
1139 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1141 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1144 typeOfExpr :: String -> InputT GHCi ()
1146 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1147 ty <- GHC.exprType str
1148 dflags <- getDynFlags
1149 let pefas = dopt Opt_PrintExplicitForalls dflags
1150 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1152 kindOfType :: String -> InputT GHCi ()
1154 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1155 ty <- GHC.typeKind str
1156 printForUser $ text str <+> dcolon <+> ppr ty
1158 quit :: String -> InputT GHCi Bool
1159 quit _ = return True
1161 shellEscape :: String -> GHCi Bool
1162 shellEscape str = io (system str >> return False)
1164 -----------------------------------------------------------------------------
1165 -- Browsing a module's contents
1167 browseCmd :: Bool -> String -> InputT GHCi ()
1170 ['*':s] | looksLikeModuleName s -> do
1171 m <- lift $ wantInterpretedModule s
1172 browseModule bang m False
1173 [s] | looksLikeModuleName s -> do
1174 m <- lift $ lookupModule s
1175 browseModule bang m True
1177 (as,bs) <- GHC.getContext
1178 -- Guess which module the user wants to browse. Pick
1179 -- modules that are interpreted first. The most
1180 -- recently-added module occurs last, it seems.
1182 (as@(_:_), _) -> browseModule bang (last as) True
1183 ([], bs@(_:_)) -> browseModule bang (last bs) True
1184 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1185 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1187 -- without bang, show items in context of their parents and omit children
1188 -- with bang, show class methods and data constructors separately, and
1189 -- indicate import modules, to aid qualifying unqualified names
1190 -- with sorted, sort items alphabetically
1191 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1192 browseModule bang modl exports_only = do
1193 -- :browse! reports qualifiers wrt current context
1194 current_unqual <- GHC.getPrintUnqual
1195 -- Temporarily set the context to the module we're interested in,
1196 -- just so we can get an appropriate PrintUnqualified
1197 (as,bs) <- GHC.getContext
1198 prel_mod <- lift getPrelude
1199 if exports_only then GHC.setContext [] [prel_mod,modl]
1200 else GHC.setContext [modl] []
1201 target_unqual <- GHC.getPrintUnqual
1202 GHC.setContext as bs
1204 let unqual = if bang then current_unqual else target_unqual
1206 mb_mod_info <- GHC.getModuleInfo modl
1208 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1209 GHC.moduleNameString (GHC.moduleName modl)))
1211 dflags <- getDynFlags
1213 | exports_only = GHC.modInfoExports mod_info
1214 | otherwise = GHC.modInfoTopLevelScope mod_info
1217 -- sort alphabetically name, but putting
1218 -- locally-defined identifiers first.
1219 -- We would like to improve this; see #1799.
1220 sorted_names = loc_sort local ++ occ_sort external
1222 (local,external) = ASSERT( all isExternalName names )
1223 partition ((==modl) . nameModule) names
1224 occ_sort = sortBy (compare `on` nameOccName)
1225 -- try to sort by src location. If the first name in
1226 -- our list has a good source location, then they all should.
1228 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1229 = sortBy (compare `on` nameSrcSpan) names
1233 mb_things <- mapM GHC.lookupName sorted_names
1234 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1236 rdr_env <- GHC.getGRE
1238 let pefas = dopt Opt_PrintExplicitForalls dflags
1239 things | bang = catMaybes mb_things
1240 | otherwise = filtered_things
1241 pretty | bang = pprTyThing
1242 | otherwise = pprTyThingInContext
1244 labels [] = text "-- not currently imported"
1245 labels l = text $ intercalate "\n" $ map qualifier l
1246 qualifier = maybe "-- defined locally"
1247 (("-- imported via "++) . intercalate ", "
1248 . map GHC.moduleNameString)
1249 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1250 modNames = map (importInfo . GHC.getName) things
1252 -- annotate groups of imports with their import modules
1253 -- the default ordering is somewhat arbitrary, so we group
1254 -- by header and sort groups; the names themselves should
1255 -- really come in order of source appearance.. (trac #1799)
1256 annotate mts = concatMap (\(m,ts)->labels m:ts)
1257 $ sortBy cmpQualifiers $ group mts
1258 where cmpQualifiers =
1259 compare `on` (map (fmap (map moduleNameFS)) . fst)
1261 group mts@((m,_):_) = (m,map snd g) : group ng
1262 where (g,ng) = partition ((==m).fst) mts
1264 let prettyThings = map (pretty pefas) things
1265 prettyThings' | bang = annotate $ zip modNames prettyThings
1266 | otherwise = prettyThings
1267 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1268 -- ToDo: modInfoInstances currently throws an exception for
1269 -- package modules. When it works, we can do this:
1270 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1272 -----------------------------------------------------------------------------
1273 -- Setting the module context
1275 setContext :: String -> GHCi ()
1277 | all sensible strs = do
1278 playCtxtCmd True (cmd, as, bs)
1280 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1281 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1283 (cmd, strs, as, bs) =
1285 '+':stuff -> rest AddModules stuff
1286 '-':stuff -> rest RemModules stuff
1287 stuff -> rest SetContext stuff
1289 rest cmd stuff = (cmd, strs, as, bs)
1290 where strs = words stuff
1291 (as,bs) = partitionWith starred strs
1293 sensible ('*':m) = looksLikeModuleName m
1294 sensible m = looksLikeModuleName m
1296 starred ('*':m) = Left m
1299 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1300 playCtxtCmd fail (cmd, as, bs)
1302 (as',bs') <- do_checks fail
1303 (prev_as,prev_bs) <- GHC.getContext
1307 prel_mod <- getPrelude
1308 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1312 let as_to_add = as' \\ (prev_as ++ prev_bs)
1313 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1314 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1316 let new_as = prev_as \\ (as' ++ bs')
1317 new_bs = prev_bs \\ (as' ++ bs')
1318 return (new_as, new_bs)
1319 GHC.setContext new_as new_bs
1322 as' <- mapM wantInterpretedModule as
1323 bs' <- mapM lookupModule bs
1325 do_checks False = do
1326 as' <- mapM (trymaybe . wantInterpretedModule) as
1327 bs' <- mapM (trymaybe . lookupModule) bs
1328 return (catMaybes as', catMaybes bs')
1333 Left _ -> return Nothing
1334 Right a -> return (Just a)
1336 ----------------------------------------------------------------------------
1339 -- set options in the interpreter. Syntax is exactly the same as the
1340 -- ghc command line, except that certain options aren't available (-C,
1343 -- This is pretty fragile: most options won't work as expected. ToDo:
1344 -- figure out which ones & disallow them.
1346 setCmd :: String -> GHCi ()
1348 = do st <- getGHCiState
1349 let opts = options st
1350 io $ putStrLn (showSDoc (
1351 text "options currently set: " <>
1354 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1356 dflags <- getDynFlags
1357 io $ putStrLn (showSDoc (
1358 vcat (text "GHCi-specific dynamic flag settings:"
1359 :map (flagSetting dflags) ghciFlags)
1361 io $ putStrLn (showSDoc (
1362 vcat (text "other dynamic, non-language, flag settings:"
1363 :map (flagSetting dflags) nonLanguageDynFlags)
1365 where flagSetting dflags (str, f, _)
1366 | dopt f dflags = text " " <> text "-f" <> text str
1367 | otherwise = text " " <> text "-fno-" <> text str
1368 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1370 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1372 flags = [Opt_PrintExplicitForalls
1373 ,Opt_PrintBindResult
1374 ,Opt_BreakOnException
1376 ,Opt_PrintEvldWithShow
1379 = case getCmd str of
1380 Right ("args", rest) ->
1382 Left err -> io (hPutStrLn stderr err)
1383 Right args -> setArgs args
1384 Right ("prog", rest) ->
1386 Right [prog] -> setProg prog
1387 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1388 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1389 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1390 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1391 _ -> case toArgs str of
1392 Left err -> io (hPutStrLn stderr err)
1393 Right wds -> setOptions wds
1395 setArgs, setOptions :: [String] -> GHCi ()
1396 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1400 setGHCiState st{ args = args }
1404 setGHCiState st{ progname = prog }
1408 setGHCiState st{ editor = cmd }
1410 setStop str@(c:_) | isDigit c
1411 = do let (nm_str,rest) = break (not.isDigit) str
1414 let old_breaks = breaks st
1415 if all ((/= nm) . fst) old_breaks
1416 then printForUser (text "Breakpoint" <+> ppr nm <+>
1417 text "does not exist")
1419 let new_breaks = map fn old_breaks
1420 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1421 | otherwise = (i,loc)
1422 setGHCiState st{ breaks = new_breaks }
1425 setGHCiState st{ stop = cmd }
1427 setPrompt value = do
1430 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1432 '\"' : _ -> case reads value of
1433 [(value', xs)] | all isSpace xs ->
1434 setGHCiState (st { prompt = value' })
1436 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1437 _ -> setGHCiState (st { prompt = value })
1440 do -- first, deal with the GHCi opts (+s, +t, etc.)
1441 let (plus_opts, minus_opts) = partitionWith isPlus wds
1442 mapM_ setOpt plus_opts
1443 -- then, dynamic flags
1444 newDynFlags minus_opts
1446 newDynFlags :: [String] -> GHCi ()
1447 newDynFlags minus_opts = do
1448 dflags <- getDynFlags
1449 let pkg_flags = packageFlags dflags
1450 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1451 handleFlagWarnings dflags' warns
1453 if (not (null leftovers))
1454 then ghcError $ errorsToGhcException leftovers
1457 new_pkgs <- setDynFlags dflags'
1459 -- if the package flags changed, we should reset the context
1460 -- and link the new packages.
1461 dflags <- getDynFlags
1462 when (packageFlags dflags /= pkg_flags) $ do
1463 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1465 _ <- GHC.load LoadAllTargets
1466 io (linkPackages dflags new_pkgs)
1467 -- package flags changed, we can't re-use any of the old context
1468 setContextAfterLoad ([],[]) False []
1472 unsetOptions :: String -> GHCi ()
1474 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1475 let opts = words str
1476 (minus_opts, rest1) = partition isMinus opts
1477 (plus_opts, rest2) = partitionWith isPlus rest1
1479 if (not (null rest2))
1480 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1483 mapM_ unsetOpt plus_opts
1485 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1486 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1488 no_flags <- mapM no_flag minus_opts
1489 newDynFlags no_flags
1491 isMinus :: String -> Bool
1492 isMinus ('-':_) = True
1495 isPlus :: String -> Either String String
1496 isPlus ('+':opt) = Left opt
1497 isPlus other = Right other
1499 setOpt, unsetOpt :: String -> GHCi ()
1502 = case strToGHCiOpt str of
1503 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1504 Just o -> setOption o
1507 = case strToGHCiOpt str of
1508 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1509 Just o -> unsetOption o
1511 strToGHCiOpt :: String -> (Maybe GHCiOption)
1512 strToGHCiOpt "s" = Just ShowTiming
1513 strToGHCiOpt "t" = Just ShowType
1514 strToGHCiOpt "r" = Just RevertCAFs
1515 strToGHCiOpt _ = Nothing
1517 optToStr :: GHCiOption -> String
1518 optToStr ShowTiming = "s"
1519 optToStr ShowType = "t"
1520 optToStr RevertCAFs = "r"
1522 -- ---------------------------------------------------------------------------
1525 showCmd :: String -> GHCi ()
1529 ["args"] -> io $ putStrLn (show (args st))
1530 ["prog"] -> io $ putStrLn (show (progname st))
1531 ["prompt"] -> io $ putStrLn (show (prompt st))
1532 ["editor"] -> io $ putStrLn (show (editor st))
1533 ["stop"] -> io $ putStrLn (show (stop st))
1534 ["modules" ] -> showModules
1535 ["bindings"] -> showBindings
1536 ["linker"] -> io showLinkerState
1537 ["breaks"] -> showBkptTable
1538 ["context"] -> showContext
1539 ["packages"] -> showPackages
1540 ["languages"] -> showLanguages
1541 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1542 " | breaks | context | packages | languages ]"))
1544 showModules :: GHCi ()
1546 loaded_mods <- getLoadedModules
1547 -- we want *loaded* modules only, see #1734
1548 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1549 mapM_ show_one loaded_mods
1551 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1552 getLoadedModules = do
1553 graph <- GHC.getModuleGraph
1554 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1556 showBindings :: GHCi ()
1558 bindings <- GHC.getBindings
1559 docs <- pprTypeAndContents
1560 [ id | AnId id <- sortBy compareTyThings bindings]
1561 printForUserPartWay docs
1563 compareTyThings :: TyThing -> TyThing -> Ordering
1564 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1566 printTyThing :: TyThing -> GHCi ()
1567 printTyThing tyth = do dflags <- getDynFlags
1568 let pefas = dopt Opt_PrintExplicitForalls dflags
1569 printForUser (pprTyThing pefas tyth)
1571 showBkptTable :: GHCi ()
1574 printForUser $ prettyLocations (breaks st)
1576 showContext :: GHCi ()
1578 resumes <- GHC.getResumeContext
1579 printForUser $ vcat (map pp_resume (reverse resumes))
1582 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1583 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1585 showPackages :: GHCi ()
1587 pkg_flags <- fmap packageFlags getDynFlags
1588 io $ putStrLn $ showSDoc $ vcat $
1589 text ("active package flags:"++if null pkg_flags then " none" else "")
1590 : map showFlag pkg_flags
1591 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1592 io $ putStrLn $ showSDoc $ vcat $
1593 text "packages currently loaded:"
1594 : map (nest 2 . text . packageIdString)
1595 (sortBy (compare `on` packageIdFS) pkg_ids)
1596 where showFlag (ExposePackage p) = text $ " -package " ++ p
1597 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1598 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1599 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1601 showLanguages :: GHCi ()
1603 dflags <- getDynFlags
1604 io $ putStrLn $ showSDoc $ vcat $
1605 text "active language flags:" :
1606 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1608 -- -----------------------------------------------------------------------------
1611 completeCmd, completeMacro, completeIdentifier, completeModule,
1612 completeHomeModule, completeSetOptions, completeShowOptions,
1613 completeHomeModuleOrFile, completeExpression
1614 :: CompletionFunc GHCi
1616 ghciCompleteWord :: CompletionFunc GHCi
1617 ghciCompleteWord line@(left,_) = case firstWord of
1618 ':':cmd | null rest -> completeCmd line
1620 completion <- lookupCompletion cmd
1622 "import" -> completeModule line
1623 _ -> completeExpression line
1625 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1626 lookupCompletion ('!':_) = return completeFilename
1627 lookupCompletion c = do
1628 maybe_cmd <- liftIO $ lookupCommand' c
1630 Just (_,_,f) -> return f
1631 Nothing -> return completeFilename
1633 completeCmd = wrapCompleter " " $ \w -> do
1634 macros <- liftIO $ readIORef macros_ref
1635 let macro_names = map (':':) . map cmdName $ macros
1636 let command_names = map (':':) . map cmdName $ builtin_commands
1637 let{ candidates = case w of
1638 ':' : ':' : _ -> map (':':) command_names
1639 _ -> nub $ macro_names ++ command_names }
1640 return $ filter (w `isPrefixOf`) candidates
1642 completeMacro = wrapIdentCompleter $ \w -> do
1643 cmds <- liftIO $ readIORef macros_ref
1644 return (filter (w `isPrefixOf`) (map cmdName cmds))
1646 completeIdentifier = wrapIdentCompleter $ \w -> do
1647 rdrs <- GHC.getRdrNamesInScope
1648 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1650 completeModule = wrapIdentCompleter $ \w -> do
1651 dflags <- GHC.getSessionDynFlags
1652 let pkg_mods = allExposedModules dflags
1653 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1654 return $ filter (w `isPrefixOf`)
1655 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1657 completeHomeModule = wrapIdentCompleter listHomeModules
1659 listHomeModules :: String -> GHCi [String]
1660 listHomeModules w = do
1661 g <- GHC.getModuleGraph
1662 let home_mods = map GHC.ms_mod_name g
1663 return $ sort $ filter (w `isPrefixOf`)
1664 $ map (showSDoc.ppr) home_mods
1666 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1667 return (filter (w `isPrefixOf`) options)
1668 where options = "args":"prog":"prompt":"editor":"stop":flagList
1669 flagList = map head $ group $ sort allFlags
1671 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1672 return (filter (w `isPrefixOf`) options)
1673 where options = ["args", "prog", "prompt", "editor", "stop",
1674 "modules", "bindings", "linker", "breaks",
1675 "context", "packages", "languages"]
1677 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1678 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1681 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1682 unionComplete f1 f2 line = do
1687 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1688 wrapCompleter breakChars fun = completeWord Nothing breakChars
1689 $ fmap (map simpleCompletion) . fmap sort . fun
1691 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1692 wrapIdentCompleter = wrapCompleter word_break_chars
1694 allExposedModules :: DynFlags -> [ModuleName]
1695 allExposedModules dflags
1696 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1698 pkg_db = pkgIdMap (pkgState dflags)
1700 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1703 -- ---------------------------------------------------------------------------
1704 -- User code exception handling
1706 -- This is the exception handler for exceptions generated by the
1707 -- user's code and exceptions coming from children sessions;
1708 -- it normally just prints out the exception. The
1709 -- handler must be recursive, in case showing the exception causes
1710 -- more exceptions to be raised.
1712 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1713 -- raising another exception. We therefore don't put the recursive
1714 -- handler arond the flushing operation, so if stderr is closed
1715 -- GHCi will just die gracefully rather than going into an infinite loop.
1716 handler :: SomeException -> GHCi Bool
1718 handler exception = do
1720 io installSignalHandlers
1721 ghciHandle handler (showException exception >> return False)
1723 showException :: SomeException -> GHCi ()
1725 io $ case fromException se of
1726 Just Interrupted -> putStrLn "Interrupted."
1727 -- omit the location for CmdLineError:
1728 Just (CmdLineError s) -> putStrLn s
1730 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1731 Just other_ghc_ex -> print other_ghc_ex
1732 Nothing -> putStrLn ("*** Exception: " ++ show se)
1734 -----------------------------------------------------------------------------
1735 -- recursive exception handlers
1737 -- Don't forget to unblock async exceptions in the handler, or if we're
1738 -- in an exception loop (eg. let a = error a in a) the ^C exception
1739 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1741 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1742 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1744 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1745 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1747 -- ----------------------------------------------------------------------------
1750 -- TODO: won't work if home dir is encoded.
1751 -- (changeDirectory may not work either in that case.)
1752 expandPath :: MonadIO m => String -> InputT m String
1753 expandPath path = do
1754 exp_path <- liftIO $ expandPathIO path
1755 enc <- fmap BS.unpack $ Encoding.encode exp_path
1758 expandPathIO :: String -> IO String
1760 case dropWhile isSpace path of
1762 tilde <- getHomeDirectory -- will fail if HOME not defined
1763 return (tilde ++ '/':d)
1767 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1768 wantInterpretedModule str = do
1769 modl <- lookupModule str
1770 dflags <- getDynFlags
1771 when (GHC.modulePackageId modl /= thisPackage dflags) $
1772 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1773 is_interpreted <- GHC.moduleIsInterpreted modl
1774 when (not is_interpreted) $
1775 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1778 wantNameFromInterpretedModule :: GHC.GhcMonad m
1779 => (Name -> SDoc -> m ())
1783 wantNameFromInterpretedModule noCanDo str and_then =
1784 handleSourceError (GHC.printExceptionAndWarnings) $ do
1785 names <- GHC.parseName str
1789 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1790 if not (GHC.isExternalName n)
1791 then noCanDo n $ ppr n <>
1792 text " is not defined in an interpreted module"
1794 is_interpreted <- GHC.moduleIsInterpreted modl
1795 if not is_interpreted
1796 then noCanDo n $ text "module " <> ppr modl <>
1797 text " is not interpreted"
1800 -- -----------------------------------------------------------------------------
1801 -- commands for debugger
1803 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1804 sprintCmd = pprintCommand False False
1805 printCmd = pprintCommand True False
1806 forceCmd = pprintCommand False True
1808 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1809 pprintCommand bind force str = do
1810 pprintClosureCommand bind force str
1812 stepCmd :: String -> GHCi ()
1813 stepCmd [] = doContinue (const True) GHC.SingleStep
1814 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1816 stepLocalCmd :: String -> GHCi ()
1817 stepLocalCmd [] = do
1818 mb_span <- getCurrentBreakSpan
1820 Nothing -> stepCmd []
1822 Just mod <- getCurrentBreakModule
1823 current_toplevel_decl <- enclosingTickSpan mod loc
1824 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1826 stepLocalCmd expression = stepCmd expression
1828 stepModuleCmd :: String -> GHCi ()
1829 stepModuleCmd [] = do
1830 mb_span <- getCurrentBreakSpan
1832 Nothing -> stepCmd []
1834 Just span <- getCurrentBreakSpan
1835 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1836 doContinue f GHC.SingleStep
1838 stepModuleCmd expression = stepCmd expression
1840 -- | Returns the span of the largest tick containing the srcspan given
1841 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1842 enclosingTickSpan mod src = do
1843 ticks <- getTickArray mod
1844 let line = srcSpanStartLine src
1845 ASSERT (inRange (bounds ticks) line) do
1846 let enclosing_spans = [ span | (_,span) <- ticks ! line
1847 , srcSpanEnd span >= srcSpanEnd src]
1848 return . head . sortBy leftmost_largest $ enclosing_spans
1850 traceCmd :: String -> GHCi ()
1851 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1852 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1854 continueCmd :: String -> GHCi ()
1855 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1857 -- doContinue :: SingleStep -> GHCi ()
1858 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1859 doContinue pred step = do
1860 runResult <- resume pred step
1861 _ <- afterRunStmt pred runResult
1864 abandonCmd :: String -> GHCi ()
1865 abandonCmd = noArgs $ do
1866 b <- GHC.abandon -- the prompt will change to indicate the new context
1867 when (not b) $ io $ putStrLn "There is no computation running."
1870 deleteCmd :: String -> GHCi ()
1871 deleteCmd argLine = do
1872 deleteSwitch $ words argLine
1874 deleteSwitch :: [String] -> GHCi ()
1876 io $ putStrLn "The delete command requires at least one argument."
1877 -- delete all break points
1878 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1879 deleteSwitch idents = do
1880 mapM_ deleteOneBreak idents
1882 deleteOneBreak :: String -> GHCi ()
1884 | all isDigit str = deleteBreak (read str)
1885 | otherwise = return ()
1887 historyCmd :: String -> GHCi ()
1889 | null arg = history 20
1890 | all isDigit arg = history (read arg)
1891 | otherwise = io $ putStrLn "Syntax: :history [num]"
1894 resumes <- GHC.getResumeContext
1896 [] -> io $ putStrLn "Not stopped at a breakpoint"
1898 let hist = GHC.resumeHistory r
1899 (took,rest) = splitAt num hist
1901 [] -> io $ putStrLn $
1902 "Empty history. Perhaps you forgot to use :trace?"
1904 spans <- mapM GHC.getHistorySpan took
1905 let nums = map (printf "-%-3d:") [(1::Int)..]
1906 names = map GHC.historyEnclosingDecl took
1907 printForUser (vcat(zipWith3
1908 (\x y z -> x <+> y <+> z)
1910 (map (bold . ppr) names)
1911 (map (parens . ppr) spans)))
1912 io $ putStrLn $ if null rest then "<end of history>" else "..."
1914 bold :: SDoc -> SDoc
1915 bold c | do_bold = text start_bold <> c <> text end_bold
1918 backCmd :: String -> GHCi ()
1919 backCmd = noArgs $ do
1920 (names, _, span) <- GHC.back
1921 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1922 printTypeOfNames names
1923 -- run the command set with ":set stop <cmd>"
1925 enqueueCommands [stop st]
1927 forwardCmd :: String -> GHCi ()
1928 forwardCmd = noArgs $ do
1929 (names, ix, span) <- GHC.forward
1930 printForUser $ (if (ix == 0)
1931 then ptext (sLit "Stopped at")
1932 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1933 printTypeOfNames names
1934 -- run the command set with ":set stop <cmd>"
1936 enqueueCommands [stop st]
1938 -- handle the "break" command
1939 breakCmd :: String -> GHCi ()
1940 breakCmd argLine = do
1941 breakSwitch $ words argLine
1943 breakSwitch :: [String] -> GHCi ()
1945 io $ putStrLn "The break command requires at least one argument."
1946 breakSwitch (arg1:rest)
1947 | looksLikeModuleName arg1 && not (null rest) = do
1948 mod <- wantInterpretedModule arg1
1949 breakByModule mod rest
1950 | all isDigit arg1 = do
1951 (toplevel, _) <- GHC.getContext
1953 (mod : _) -> breakByModuleLine mod (read arg1) rest
1955 io $ putStrLn "Cannot find default module for breakpoint."
1956 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1957 | otherwise = do -- try parsing it as an identifier
1958 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1959 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1960 if GHC.isGoodSrcLoc loc
1961 then ASSERT( isExternalName name )
1962 findBreakAndSet (GHC.nameModule name) $
1963 findBreakByCoord (Just (GHC.srcLocFile loc))
1964 (GHC.srcLocLine loc,
1966 else noCanDo name $ text "can't find its location: " <> ppr loc
1968 noCanDo n why = printForUser $
1969 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1971 breakByModule :: Module -> [String] -> GHCi ()
1972 breakByModule mod (arg1:rest)
1973 | all isDigit arg1 = do -- looks like a line number
1974 breakByModuleLine mod (read arg1) rest
1978 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1979 breakByModuleLine mod line args
1980 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1981 | [col] <- args, all isDigit col =
1982 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1983 | otherwise = breakSyntax
1986 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1988 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1989 findBreakAndSet mod lookupTickTree = do
1990 tickArray <- getTickArray mod
1991 (breakArray, _) <- getModBreak mod
1992 case lookupTickTree tickArray of
1993 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1994 Just (tick, span) -> do
1995 success <- io $ setBreakFlag True breakArray tick
1999 recordBreak $ BreakLocation
2006 text "Breakpoint " <> ppr nm <>
2008 then text " was already set at " <> ppr span
2009 else text " activated at " <> ppr span
2011 printForUser $ text "Breakpoint could not be activated at"
2014 -- When a line number is specified, the current policy for choosing
2015 -- the best breakpoint is this:
2016 -- - the leftmost complete subexpression on the specified line, or
2017 -- - the leftmost subexpression starting on the specified line, or
2018 -- - the rightmost subexpression enclosing the specified line
2020 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2021 findBreakByLine line arr
2022 | not (inRange (bounds arr) line) = Nothing
2024 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2025 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2026 listToMaybe (sortBy (rightmost `on` snd) ticks)
2030 starts_here = [ tick | tick@(_,span) <- ticks,
2031 GHC.srcSpanStartLine span == line ]
2033 (complete,incomplete) = partition ends_here starts_here
2034 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2036 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2037 -> Maybe (BreakIndex,SrcSpan)
2038 findBreakByCoord mb_file (line, col) arr
2039 | not (inRange (bounds arr) line) = Nothing
2041 listToMaybe (sortBy (rightmost `on` snd) contains ++
2042 sortBy (leftmost_smallest `on` snd) after_here)
2046 -- the ticks that span this coordinate
2047 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2048 is_correct_file span ]
2050 is_correct_file span
2051 | Just f <- mb_file = GHC.srcSpanFile span == f
2054 after_here = [ tick | tick@(_,span) <- ticks,
2055 GHC.srcSpanStartLine span == line,
2056 GHC.srcSpanStartCol span >= col ]
2058 -- For now, use ANSI bold on terminals that we know support it.
2059 -- Otherwise, we add a line of carets under the active expression instead.
2060 -- In particular, on Windows and when running the testsuite (which sets
2061 -- TERM to vt100 for other reasons) we get carets.
2062 -- We really ought to use a proper termcap/terminfo library.
2064 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2065 where mTerm = System.Environment.getEnv "TERM"
2066 `catchIO` \_ -> return "TERM not set"
2068 start_bold :: String
2069 start_bold = "\ESC[1m"
2071 end_bold = "\ESC[0m"
2073 listCmd :: String -> InputT GHCi ()
2075 mb_span <- lift getCurrentBreakSpan
2078 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2080 | GHC.isGoodSrcSpan span -> listAround span True
2082 do resumes <- GHC.getResumeContext
2084 [] -> panic "No resumes"
2086 do let traceIt = case GHC.resumeHistory r of
2087 [] -> text "rerunning with :trace,"
2089 doWhat = traceIt <+> text ":back then :list"
2090 printForUser (text "Unable to list source for" <+>
2092 $$ text "Try" <+> doWhat)
2093 listCmd str = list2 (words str)
2095 list2 :: [String] -> InputT GHCi ()
2096 list2 [arg] | all isDigit arg = do
2097 (toplevel, _) <- GHC.getContext
2099 [] -> outputStrLn "No module to list"
2100 (mod : _) -> listModuleLine mod (read arg)
2101 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2102 mod <- wantInterpretedModule arg1
2103 listModuleLine mod (read arg2)
2105 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2106 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2107 if GHC.isGoodSrcLoc loc
2109 tickArray <- ASSERT( isExternalName name )
2110 lift $ getTickArray (GHC.nameModule name)
2111 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2112 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2115 Nothing -> listAround (GHC.srcLocSpan loc) False
2116 Just (_,span) -> listAround span False
2118 noCanDo name $ text "can't find its location: " <>
2121 noCanDo n why = printForUser $
2122 text "cannot list source code for " <> ppr n <> text ": " <> why
2124 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2126 listModuleLine :: Module -> Int -> InputT GHCi ()
2127 listModuleLine modl line = do
2128 graph <- GHC.getModuleGraph
2129 let this = filter ((== modl) . GHC.ms_mod) graph
2131 [] -> panic "listModuleLine"
2133 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2134 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2135 listAround (GHC.srcLocSpan loc) False
2137 -- | list a section of a source file around a particular SrcSpan.
2138 -- If the highlight flag is True, also highlight the span using
2139 -- start_bold\/end_bold.
2141 -- GHC files are UTF-8, so we can implement this by:
2142 -- 1) read the file in as a BS and syntax highlight it as before
2143 -- 2) convert the BS to String using utf-string, and write it out.
2144 -- It would be better if we could convert directly between UTF-8 and the
2145 -- console encoding, of course.
2146 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2147 listAround span do_highlight = do
2148 contents <- liftIO $ BS.readFile (unpackFS file)
2150 lines = BS.split '\n' contents
2151 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2152 drop (line1 - 1 - pad_before) $ lines
2153 fst_line = max 1 (line1 - pad_before)
2154 line_nos = [ fst_line .. ]
2156 highlighted | do_highlight = zipWith highlight line_nos these_lines
2157 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2159 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2160 prefixed = zipWith ($) highlighted bs_line_nos
2162 let output = BS.intercalate (BS.pack "\n") prefixed
2163 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2164 $ \(p,n) -> utf8DecodeString (castPtr p) n
2165 outputStrLn utf8Decoded
2167 file = GHC.srcSpanFile span
2168 line1 = GHC.srcSpanStartLine span
2169 col1 = GHC.srcSpanStartCol span - 1
2170 line2 = GHC.srcSpanEndLine span
2171 col2 = GHC.srcSpanEndCol span - 1
2173 pad_before | line1 == 1 = 0
2177 highlight | do_bold = highlight_bold
2178 | otherwise = highlight_carets
2180 highlight_bold no line prefix
2181 | no == line1 && no == line2
2182 = let (a,r) = BS.splitAt col1 line
2183 (b,c) = BS.splitAt (col2-col1) r
2185 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2187 = let (a,b) = BS.splitAt col1 line in
2188 BS.concat [prefix, a, BS.pack start_bold, b]
2190 = let (a,b) = BS.splitAt col2 line in
2191 BS.concat [prefix, a, BS.pack end_bold, b]
2192 | otherwise = BS.concat [prefix, line]
2194 highlight_carets no line prefix
2195 | no == line1 && no == line2
2196 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2197 BS.replicate (col2-col1) '^']
2199 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2202 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2204 | otherwise = BS.concat [prefix, line]
2206 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2207 nl = BS.singleton '\n'
2209 -- --------------------------------------------------------------------------
2212 getTickArray :: Module -> GHCi TickArray
2213 getTickArray modl = do
2215 let arrmap = tickarrays st
2216 case lookupModuleEnv arrmap modl of
2217 Just arr -> return arr
2219 (_breakArray, ticks) <- getModBreak modl
2220 let arr = mkTickArray (assocs ticks)
2221 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2224 discardTickArrays :: GHCi ()
2225 discardTickArrays = do
2227 setGHCiState st{tickarrays = emptyModuleEnv}
2229 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2231 = accumArray (flip (:)) [] (1, max_line)
2232 [ (line, (nm,span)) | (nm,span) <- ticks,
2233 line <- srcSpanLines span ]
2235 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2236 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2237 GHC.srcSpanEndLine span ]
2239 lookupModule :: GHC.GhcMonad m => String -> m Module
2240 lookupModule modName
2241 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2243 -- don't reset the counter back to zero?
2244 discardActiveBreakPoints :: GHCi ()
2245 discardActiveBreakPoints = do
2247 mapM_ (turnOffBreak.snd) (breaks st)
2248 setGHCiState $ st { breaks = [] }
2250 deleteBreak :: Int -> GHCi ()
2251 deleteBreak identity = do
2253 let oldLocations = breaks st
2254 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2256 then printForUser (text "Breakpoint" <+> ppr identity <+>
2257 text "does not exist")
2259 mapM_ (turnOffBreak.snd) this
2260 setGHCiState $ st { breaks = rest }
2262 turnOffBreak :: BreakLocation -> GHCi Bool
2263 turnOffBreak loc = do
2264 (arr, _) <- getModBreak (breakModule loc)
2265 io $ setBreakFlag False arr (breakTick loc)
2267 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2268 getModBreak mod = do
2269 Just mod_info <- GHC.getModuleInfo mod
2270 let modBreaks = GHC.modInfoModBreaks mod_info
2271 let array = GHC.modBreaks_flags modBreaks
2272 let ticks = GHC.modBreaks_locs modBreaks
2273 return (array, ticks)
2275 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2276 setBreakFlag toggle array index
2277 | toggle = GHC.setBreakOn array index
2278 | otherwise = GHC.setBreakOff array index