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 ( 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 = filterOut has_parent xs
829 all_names = mkNameSet (map (getName . get_thing) xs)
830 has_parent x = case pprTyThingParent_maybe (get_thing x) of
831 Just p -> getName p `elemNameSet` all_names
834 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
835 pprInfo pefas (thing, fixity, insts)
836 = pprTyThingInContextLoc pefas thing
837 $$ show_fixity fixity
838 $$ vcat (map GHC.pprInstance insts)
841 | fix == GHC.defaultFixity = empty
842 | otherwise = ppr fix <+> ppr (GHC.getName thing)
844 runMain :: String -> GHCi ()
845 runMain s = case toArgs s of
846 Left err -> io (hPutStrLn stderr err)
848 do dflags <- getDynFlags
849 case mainFunIs dflags of
850 Nothing -> doWithArgs args "main"
851 Just f -> doWithArgs args f
853 runRun :: String -> GHCi ()
854 runRun s = case toCmdArgs s of
855 Left err -> io (hPutStrLn stderr err)
856 Right (cmd, args) -> doWithArgs args cmd
858 doWithArgs :: [String] -> String -> GHCi ()
859 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
860 show args ++ " (" ++ cmd ++ ")"]
862 addModule :: [FilePath] -> InputT GHCi ()
864 lift revertCAFs -- always revert CAFs on load/add.
865 files <- mapM expandPath files
866 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
867 -- remove old targets with the same id; e.g. for :add *M
868 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
869 mapM_ GHC.addTarget targets
870 prev_context <- GHC.getContext
871 ok <- trySuccess $ GHC.load LoadAllTargets
872 afterLoad ok False prev_context
874 changeDirectory :: String -> InputT GHCi ()
875 changeDirectory "" = do
876 -- :cd on its own changes to the user's home directory
877 either_dir <- liftIO $ IO.try getHomeDirectory
880 Right dir -> changeDirectory dir
881 changeDirectory dir = do
882 graph <- GHC.getModuleGraph
883 when (not (null graph)) $
884 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
885 prev_context <- GHC.getContext
887 _ <- GHC.load LoadAllTargets
888 lift $ setContextAfterLoad prev_context False []
889 GHC.workingDirectoryChanged
890 dir <- expandPath dir
891 liftIO $ setCurrentDirectory dir
893 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
895 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
899 editFile :: String -> GHCi ()
901 do file <- if null str then chooseEditFile else return str
905 $ ghcError (CmdLineError "editor not set, use :set editor")
906 _ <- io $ system (cmd ++ ' ':file)
909 -- The user didn't specify a file so we pick one for them.
910 -- Our strategy is to pick the first module that failed to load,
911 -- or otherwise the first target.
913 -- XXX: Can we figure out what happened if the depndecy analysis fails
914 -- (e.g., because the porgrammeer mistyped the name of a module)?
915 -- XXX: Can we figure out the location of an error to pass to the editor?
916 -- XXX: if we could figure out the list of errors that occured during the
917 -- last load/reaload, then we could start the editor focused on the first
919 chooseEditFile :: GHCi String
921 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
923 graph <- GHC.getModuleGraph
924 failed_graph <- filterM hasFailed graph
925 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
927 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
930 case pick (order failed_graph) of
931 Just file -> return file
933 do targets <- GHC.getTargets
934 case msum (map fromTarget targets) of
935 Just file -> return file
936 Nothing -> ghcError (CmdLineError "No files to edit.")
938 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
939 fromTarget _ = Nothing -- when would we get a module target?
941 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
942 defineMacro _ (':':_) =
943 io $ putStrLn "macro name cannot start with a colon"
944 defineMacro overwrite s = do
945 let (macro_name, definition) = break isSpace s
946 macros <- io (readIORef macros_ref)
947 let defined = map cmdName macros
950 then io $ putStrLn "no macros defined"
951 else io $ putStr ("the following macros are defined:\n" ++
954 if (not overwrite && macro_name `elem` defined)
955 then ghcError (CmdLineError
956 ("macro '" ++ macro_name ++ "' is already defined"))
959 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
961 -- give the expression a type signature, so we can be sure we're getting
962 -- something of the right type.
963 let new_expr = '(' : definition ++ ") :: String -> IO String"
965 -- compile the expression
966 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
967 hv <- GHC.compileExpr new_expr
968 io (writeIORef macros_ref --
969 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
971 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
973 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
974 -- make sure we force any exceptions in the result, while we are still
975 -- inside the exception handler for commands:
976 seqList str (return ())
977 enqueueCommands (lines str)
980 undefineMacro :: String -> GHCi ()
981 undefineMacro str = mapM_ undef (words str)
982 where undef macro_name = do
983 cmds <- io (readIORef macros_ref)
984 if (macro_name `notElem` map cmdName cmds)
985 then ghcError (CmdLineError
986 ("macro '" ++ macro_name ++ "' is not defined"))
988 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
990 cmdCmd :: String -> GHCi ()
992 let expr = '(' : str ++ ") :: IO String"
993 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
994 hv <- GHC.compileExpr expr
995 cmds <- io $ (unsafeCoerce# hv :: IO String)
996 enqueueCommands (lines cmds)
999 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1000 loadModule fs = timeIt (loadModule' fs)
1002 loadModule_ :: [FilePath] -> InputT GHCi ()
1003 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
1005 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
1006 loadModule' files = do
1007 prev_context <- GHC.getContext
1011 lift discardActiveBreakPoints
1013 _ <- GHC.load LoadAllTargets
1015 let (filenames, phases) = unzip files
1016 exp_filenames <- mapM expandPath filenames
1017 let files' = zip exp_filenames phases
1018 targets <- mapM (uncurry GHC.guessTarget) files'
1020 -- NOTE: we used to do the dependency anal first, so that if it
1021 -- fails we didn't throw away the current set of modules. This would
1022 -- require some re-working of the GHC interface, so we'll leave it
1023 -- as a ToDo for now.
1025 GHC.setTargets targets
1026 doLoad False prev_context LoadAllTargets
1028 checkModule :: String -> InputT GHCi ()
1030 let modl = GHC.mkModuleName m
1031 prev_context <- GHC.getContext
1032 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1033 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1034 outputStrLn (showSDoc (
1035 case GHC.moduleInfo r of
1036 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1038 (local,global) = ASSERT( all isExternalName scope )
1039 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1041 (text "global names: " <+> ppr global) $$
1042 (text "local names: " <+> ppr local)
1045 afterLoad (successIf ok) False prev_context
1047 reloadModule :: String -> InputT GHCi ()
1049 prev_context <- GHC.getContext
1050 _ <- doLoad True prev_context $
1051 if null m then LoadAllTargets
1052 else LoadUpTo (GHC.mkModuleName m)
1055 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1056 doLoad retain_context prev_context howmuch = do
1057 -- turn off breakpoints before we load: we can't turn them off later, because
1058 -- the ModBreaks will have gone away.
1059 lift discardActiveBreakPoints
1060 ok <- trySuccess $ GHC.load howmuch
1061 afterLoad ok retain_context prev_context
1064 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1065 afterLoad ok retain_context prev_context = do
1066 lift revertCAFs -- always revert CAFs on load.
1067 lift discardTickArrays
1068 loaded_mod_summaries <- getLoadedModules
1069 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1070 loaded_mod_names = map GHC.moduleName loaded_mods
1071 modulesLoadedMsg ok loaded_mod_names
1073 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1076 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1077 setContextAfterLoad prev keep_ctxt [] = do
1078 prel_mod <- getPrelude
1079 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1080 setContextAfterLoad prev keep_ctxt ms = do
1081 -- load a target if one is available, otherwise load the topmost module.
1082 targets <- GHC.getTargets
1083 case [ m | Just m <- map (findTarget ms) targets ] of
1085 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1086 load_this (last graph')
1091 = case filter (`matches` t) ms of
1095 summary `matches` Target (TargetModule m) _ _
1096 = GHC.ms_mod_name summary == m
1097 summary `matches` Target (TargetFile f _) _ _
1098 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1102 load_this summary | m <- GHC.ms_mod summary = do
1103 b <- GHC.moduleIsInterpreted m
1104 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1106 prel_mod <- getPrelude
1107 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1109 -- | Keep any package modules (except Prelude) when changing the context.
1110 setContextKeepingPackageModules
1111 :: ([Module],[Module]) -- previous context
1112 -> Bool -- re-execute :module commands
1113 -> ([Module],[Module]) -- new context
1115 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1116 let (_,bs0) = prev_context
1117 prel_mod <- getPrelude
1118 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1119 let bs1 = if null as then nub (prel_mod : bs) else bs
1120 GHC.setContext as (nub (bs1 ++ pkg_modules))
1124 mapM_ (playCtxtCmd False) (remembered_ctx st)
1127 setGHCiState st{ remembered_ctx = [] }
1129 isHomeModule :: Module -> Bool
1130 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1132 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1133 modulesLoadedMsg ok mods = do
1134 dflags <- getDynFlags
1135 when (verbosity dflags > 0) $ do
1137 | null mods = text "none."
1138 | otherwise = hsep (
1139 punctuate comma (map ppr mods)) <> text "."
1142 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1144 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1147 typeOfExpr :: String -> InputT GHCi ()
1149 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1150 ty <- GHC.exprType str
1151 dflags <- getDynFlags
1152 let pefas = dopt Opt_PrintExplicitForalls dflags
1153 printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1155 kindOfType :: String -> InputT GHCi ()
1157 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1158 ty <- GHC.typeKind str
1159 printForUser $ text str <+> dcolon <+> ppr ty
1161 quit :: String -> InputT GHCi Bool
1162 quit _ = return True
1164 shellEscape :: String -> GHCi Bool
1165 shellEscape str = io (system str >> return False)
1167 -----------------------------------------------------------------------------
1168 -- Browsing a module's contents
1170 browseCmd :: Bool -> String -> InputT GHCi ()
1173 ['*':s] | looksLikeModuleName s -> do
1174 m <- lift $ wantInterpretedModule s
1175 browseModule bang m False
1176 [s] | looksLikeModuleName s -> do
1177 m <- lift $ lookupModule s
1178 browseModule bang m True
1180 (as,bs) <- GHC.getContext
1181 -- Guess which module the user wants to browse. Pick
1182 -- modules that are interpreted first. The most
1183 -- recently-added module occurs last, it seems.
1185 (as@(_:_), _) -> browseModule bang (last as) True
1186 ([], bs@(_:_)) -> browseModule bang (last bs) True
1187 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1188 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1190 -- without bang, show items in context of their parents and omit children
1191 -- with bang, show class methods and data constructors separately, and
1192 -- indicate import modules, to aid qualifying unqualified names
1193 -- with sorted, sort items alphabetically
1194 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1195 browseModule bang modl exports_only = do
1196 -- :browse! reports qualifiers wrt current context
1197 current_unqual <- GHC.getPrintUnqual
1198 -- Temporarily set the context to the module we're interested in,
1199 -- just so we can get an appropriate PrintUnqualified
1200 (as,bs) <- GHC.getContext
1201 prel_mod <- lift getPrelude
1202 if exports_only then GHC.setContext [] [prel_mod,modl]
1203 else GHC.setContext [modl] []
1204 target_unqual <- GHC.getPrintUnqual
1205 GHC.setContext as bs
1207 let unqual = if bang then current_unqual else target_unqual
1209 mb_mod_info <- GHC.getModuleInfo modl
1211 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1212 GHC.moduleNameString (GHC.moduleName modl)))
1214 dflags <- getDynFlags
1216 | exports_only = GHC.modInfoExports mod_info
1217 | otherwise = GHC.modInfoTopLevelScope mod_info
1220 -- sort alphabetically name, but putting
1221 -- locally-defined identifiers first.
1222 -- We would like to improve this; see #1799.
1223 sorted_names = loc_sort local ++ occ_sort external
1225 (local,external) = ASSERT( all isExternalName names )
1226 partition ((==modl) . nameModule) names
1227 occ_sort = sortBy (compare `on` nameOccName)
1228 -- try to sort by src location. If the first name in
1229 -- our list has a good source location, then they all should.
1231 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1232 = sortBy (compare `on` nameSrcSpan) names
1236 mb_things <- mapM GHC.lookupName sorted_names
1237 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1239 rdr_env <- GHC.getGRE
1241 let pefas = dopt Opt_PrintExplicitForalls dflags
1242 things | bang = catMaybes mb_things
1243 | otherwise = filtered_things
1244 pretty | bang = pprTyThing
1245 | otherwise = pprTyThingInContext
1247 labels [] = text "-- not currently imported"
1248 labels l = text $ intercalate "\n" $ map qualifier l
1249 qualifier = maybe "-- defined locally"
1250 (("-- imported via "++) . intercalate ", "
1251 . map GHC.moduleNameString)
1252 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1253 modNames = map (importInfo . GHC.getName) things
1255 -- annotate groups of imports with their import modules
1256 -- the default ordering is somewhat arbitrary, so we group
1257 -- by header and sort groups; the names themselves should
1258 -- really come in order of source appearance.. (trac #1799)
1259 annotate mts = concatMap (\(m,ts)->labels m:ts)
1260 $ sortBy cmpQualifiers $ group mts
1261 where cmpQualifiers =
1262 compare `on` (map (fmap (map moduleNameFS)) . fst)
1264 group mts@((m,_):_) = (m,map snd g) : group ng
1265 where (g,ng) = partition ((==m).fst) mts
1267 let prettyThings = map (pretty pefas) things
1268 prettyThings' | bang = annotate $ zip modNames prettyThings
1269 | otherwise = prettyThings
1270 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1271 -- ToDo: modInfoInstances currently throws an exception for
1272 -- package modules. When it works, we can do this:
1273 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1275 -----------------------------------------------------------------------------
1276 -- Setting the module context
1278 setContext :: String -> GHCi ()
1280 | all sensible strs = do
1281 playCtxtCmd True (cmd, as, bs)
1283 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1284 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1286 (cmd, strs, as, bs) =
1288 '+':stuff -> rest AddModules stuff
1289 '-':stuff -> rest RemModules stuff
1290 stuff -> rest SetContext stuff
1292 rest cmd stuff = (cmd, strs, as, bs)
1293 where strs = words stuff
1294 (as,bs) = partitionWith starred strs
1296 sensible ('*':m) = looksLikeModuleName m
1297 sensible m = looksLikeModuleName m
1299 starred ('*':m) = Left m
1302 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1303 playCtxtCmd fail (cmd, as, bs)
1305 (as',bs') <- do_checks fail
1306 (prev_as,prev_bs) <- GHC.getContext
1310 prel_mod <- getPrelude
1311 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1315 let as_to_add = as' \\ (prev_as ++ prev_bs)
1316 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1317 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1319 let new_as = prev_as \\ (as' ++ bs')
1320 new_bs = prev_bs \\ (as' ++ bs')
1321 return (new_as, new_bs)
1322 GHC.setContext new_as new_bs
1325 as' <- mapM wantInterpretedModule as
1326 bs' <- mapM lookupModule bs
1328 do_checks False = do
1329 as' <- mapM (trymaybe . wantInterpretedModule) as
1330 bs' <- mapM (trymaybe . lookupModule) bs
1331 return (catMaybes as', catMaybes bs')
1336 Left _ -> return Nothing
1337 Right a -> return (Just a)
1339 ----------------------------------------------------------------------------
1342 -- set options in the interpreter. Syntax is exactly the same as the
1343 -- ghc command line, except that certain options aren't available (-C,
1346 -- This is pretty fragile: most options won't work as expected. ToDo:
1347 -- figure out which ones & disallow them.
1349 setCmd :: String -> GHCi ()
1351 = do st <- getGHCiState
1352 let opts = options st
1353 io $ putStrLn (showSDoc (
1354 text "options currently set: " <>
1357 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1359 dflags <- getDynFlags
1360 io $ putStrLn (showSDoc (
1361 vcat (text "GHCi-specific dynamic flag settings:"
1362 :map (flagSetting dflags) ghciFlags)
1364 io $ putStrLn (showSDoc (
1365 vcat (text "other dynamic, non-language, flag settings:"
1366 :map (flagSetting dflags) nonLanguageDynFlags)
1368 where flagSetting dflags (str, f, _)
1369 | dopt f dflags = text " " <> text "-f" <> text str
1370 | otherwise = text " " <> text "-fno-" <> text str
1371 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1373 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1375 flags = [Opt_PrintExplicitForalls
1376 ,Opt_PrintBindResult
1377 ,Opt_BreakOnException
1379 ,Opt_PrintEvldWithShow
1382 = case getCmd str of
1383 Right ("args", rest) ->
1385 Left err -> io (hPutStrLn stderr err)
1386 Right args -> setArgs args
1387 Right ("prog", rest) ->
1389 Right [prog] -> setProg prog
1390 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1391 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1392 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1393 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1394 _ -> case toArgs str of
1395 Left err -> io (hPutStrLn stderr err)
1396 Right wds -> setOptions wds
1398 setArgs, setOptions :: [String] -> GHCi ()
1399 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1403 setGHCiState st{ args = args }
1407 setGHCiState st{ progname = prog }
1411 setGHCiState st{ editor = cmd }
1413 setStop str@(c:_) | isDigit c
1414 = do let (nm_str,rest) = break (not.isDigit) str
1417 let old_breaks = breaks st
1418 if all ((/= nm) . fst) old_breaks
1419 then printForUser (text "Breakpoint" <+> ppr nm <+>
1420 text "does not exist")
1422 let new_breaks = map fn old_breaks
1423 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1424 | otherwise = (i,loc)
1425 setGHCiState st{ breaks = new_breaks }
1428 setGHCiState st{ stop = cmd }
1430 setPrompt value = do
1433 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1435 '\"' : _ -> case reads value of
1436 [(value', xs)] | all isSpace xs ->
1437 setGHCiState (st { prompt = value' })
1439 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1440 _ -> setGHCiState (st { prompt = value })
1443 do -- first, deal with the GHCi opts (+s, +t, etc.)
1444 let (plus_opts, minus_opts) = partitionWith isPlus wds
1445 mapM_ setOpt plus_opts
1446 -- then, dynamic flags
1447 newDynFlags minus_opts
1449 newDynFlags :: [String] -> GHCi ()
1450 newDynFlags minus_opts = do
1451 dflags <- getDynFlags
1452 let pkg_flags = packageFlags dflags
1453 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1454 handleFlagWarnings dflags' warns
1456 if (not (null leftovers))
1457 then ghcError $ errorsToGhcException leftovers
1460 new_pkgs <- setDynFlags dflags'
1462 -- if the package flags changed, we should reset the context
1463 -- and link the new packages.
1464 dflags <- getDynFlags
1465 when (packageFlags dflags /= pkg_flags) $ do
1466 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1468 _ <- GHC.load LoadAllTargets
1469 io (linkPackages dflags new_pkgs)
1470 -- package flags changed, we can't re-use any of the old context
1471 setContextAfterLoad ([],[]) False []
1475 unsetOptions :: String -> GHCi ()
1477 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1478 let opts = words str
1479 (minus_opts, rest1) = partition isMinus opts
1480 (plus_opts, rest2) = partitionWith isPlus rest1
1482 if (not (null rest2))
1483 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1486 mapM_ unsetOpt plus_opts
1488 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1489 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1491 no_flags <- mapM no_flag minus_opts
1492 newDynFlags no_flags
1494 isMinus :: String -> Bool
1495 isMinus ('-':_) = True
1498 isPlus :: String -> Either String String
1499 isPlus ('+':opt) = Left opt
1500 isPlus other = Right other
1502 setOpt, unsetOpt :: String -> GHCi ()
1505 = case strToGHCiOpt str of
1506 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1507 Just o -> setOption o
1510 = case strToGHCiOpt str of
1511 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1512 Just o -> unsetOption o
1514 strToGHCiOpt :: String -> (Maybe GHCiOption)
1515 strToGHCiOpt "s" = Just ShowTiming
1516 strToGHCiOpt "t" = Just ShowType
1517 strToGHCiOpt "r" = Just RevertCAFs
1518 strToGHCiOpt _ = Nothing
1520 optToStr :: GHCiOption -> String
1521 optToStr ShowTiming = "s"
1522 optToStr ShowType = "t"
1523 optToStr RevertCAFs = "r"
1525 -- ---------------------------------------------------------------------------
1528 showCmd :: String -> GHCi ()
1532 ["args"] -> io $ putStrLn (show (args st))
1533 ["prog"] -> io $ putStrLn (show (progname st))
1534 ["prompt"] -> io $ putStrLn (show (prompt st))
1535 ["editor"] -> io $ putStrLn (show (editor st))
1536 ["stop"] -> io $ putStrLn (show (stop st))
1537 ["modules" ] -> showModules
1538 ["bindings"] -> showBindings
1539 ["linker"] -> io showLinkerState
1540 ["breaks"] -> showBkptTable
1541 ["context"] -> showContext
1542 ["packages"] -> showPackages
1543 ["languages"] -> showLanguages
1544 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1545 " | breaks | context | packages | languages ]"))
1547 showModules :: GHCi ()
1549 loaded_mods <- getLoadedModules
1550 -- we want *loaded* modules only, see #1734
1551 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1552 mapM_ show_one loaded_mods
1554 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1555 getLoadedModules = do
1556 graph <- GHC.getModuleGraph
1557 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1559 showBindings :: GHCi ()
1561 bindings <- GHC.getBindings
1562 docs <- pprTypeAndContents
1563 [ id | AnId id <- sortBy compareTyThings bindings]
1564 printForUserPartWay docs
1566 compareTyThings :: TyThing -> TyThing -> Ordering
1567 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1569 printTyThing :: TyThing -> GHCi ()
1570 printTyThing tyth = do dflags <- getDynFlags
1571 let pefas = dopt Opt_PrintExplicitForalls dflags
1572 printForUser (pprTyThing pefas tyth)
1574 showBkptTable :: GHCi ()
1577 printForUser $ prettyLocations (breaks st)
1579 showContext :: GHCi ()
1581 resumes <- GHC.getResumeContext
1582 printForUser $ vcat (map pp_resume (reverse resumes))
1585 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1586 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1588 showPackages :: GHCi ()
1590 pkg_flags <- fmap packageFlags getDynFlags
1591 io $ putStrLn $ showSDoc $ vcat $
1592 text ("active package flags:"++if null pkg_flags then " none" else "")
1593 : map showFlag pkg_flags
1594 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1595 io $ putStrLn $ showSDoc $ vcat $
1596 text "packages currently loaded:"
1597 : map (nest 2 . text . packageIdString)
1598 (sortBy (compare `on` packageIdFS) pkg_ids)
1599 where showFlag (ExposePackage p) = text $ " -package " ++ p
1600 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1601 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1602 showFlag (ExposePackageId p) = text $ " -package-id " ++ p
1604 showLanguages :: GHCi ()
1606 dflags <- getDynFlags
1607 io $ putStrLn $ showSDoc $ vcat $
1608 text "active language flags:" :
1609 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1611 -- -----------------------------------------------------------------------------
1614 completeCmd, completeMacro, completeIdentifier, completeModule,
1615 completeHomeModule, completeSetOptions, completeShowOptions,
1616 completeHomeModuleOrFile, completeExpression
1617 :: CompletionFunc GHCi
1619 ghciCompleteWord :: CompletionFunc GHCi
1620 ghciCompleteWord line@(left,_) = case firstWord of
1621 ':':cmd | null rest -> completeCmd line
1623 completion <- lookupCompletion cmd
1625 "import" -> completeModule line
1626 _ -> completeExpression line
1628 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1629 lookupCompletion ('!':_) = return completeFilename
1630 lookupCompletion c = do
1631 maybe_cmd <- liftIO $ lookupCommand' c
1633 Just (_,_,f) -> return f
1634 Nothing -> return completeFilename
1636 completeCmd = wrapCompleter " " $ \w -> do
1637 macros <- liftIO $ readIORef macros_ref
1638 let macro_names = map (':':) . map cmdName $ macros
1639 let command_names = map (':':) . map cmdName $ builtin_commands
1640 let{ candidates = case w of
1641 ':' : ':' : _ -> map (':':) command_names
1642 _ -> nub $ macro_names ++ command_names }
1643 return $ filter (w `isPrefixOf`) candidates
1645 completeMacro = wrapIdentCompleter $ \w -> do
1646 cmds <- liftIO $ readIORef macros_ref
1647 return (filter (w `isPrefixOf`) (map cmdName cmds))
1649 completeIdentifier = wrapIdentCompleter $ \w -> do
1650 rdrs <- GHC.getRdrNamesInScope
1651 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1653 completeModule = wrapIdentCompleter $ \w -> do
1654 dflags <- GHC.getSessionDynFlags
1655 let pkg_mods = allExposedModules dflags
1656 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1657 return $ filter (w `isPrefixOf`)
1658 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1660 completeHomeModule = wrapIdentCompleter listHomeModules
1662 listHomeModules :: String -> GHCi [String]
1663 listHomeModules w = do
1664 g <- GHC.getModuleGraph
1665 let home_mods = map GHC.ms_mod_name g
1666 return $ sort $ filter (w `isPrefixOf`)
1667 $ map (showSDoc.ppr) home_mods
1669 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1670 return (filter (w `isPrefixOf`) options)
1671 where options = "args":"prog":"prompt":"editor":"stop":flagList
1672 flagList = map head $ group $ sort allFlags
1674 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1675 return (filter (w `isPrefixOf`) options)
1676 where options = ["args", "prog", "prompt", "editor", "stop",
1677 "modules", "bindings", "linker", "breaks",
1678 "context", "packages", "languages"]
1680 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1681 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1684 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1685 unionComplete f1 f2 line = do
1690 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1691 wrapCompleter breakChars fun = completeWord Nothing breakChars
1692 $ fmap (map simpleCompletion) . fmap sort . fun
1694 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1695 wrapIdentCompleter = wrapCompleter word_break_chars
1697 allExposedModules :: DynFlags -> [ModuleName]
1698 allExposedModules dflags
1699 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1701 pkg_db = pkgIdMap (pkgState dflags)
1703 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1706 -- ---------------------------------------------------------------------------
1707 -- User code exception handling
1709 -- This is the exception handler for exceptions generated by the
1710 -- user's code and exceptions coming from children sessions;
1711 -- it normally just prints out the exception. The
1712 -- handler must be recursive, in case showing the exception causes
1713 -- more exceptions to be raised.
1715 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1716 -- raising another exception. We therefore don't put the recursive
1717 -- handler arond the flushing operation, so if stderr is closed
1718 -- GHCi will just die gracefully rather than going into an infinite loop.
1719 handler :: SomeException -> GHCi Bool
1721 handler exception = do
1723 io installSignalHandlers
1724 ghciHandle handler (showException exception >> return False)
1726 showException :: SomeException -> GHCi ()
1728 io $ case fromException se of
1729 Just Interrupted -> putStrLn "Interrupted."
1730 -- omit the location for CmdLineError:
1731 Just (CmdLineError s) -> putStrLn s
1733 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1734 Just other_ghc_ex -> print other_ghc_ex
1735 Nothing -> putStrLn ("*** Exception: " ++ show se)
1737 -----------------------------------------------------------------------------
1738 -- recursive exception handlers
1740 -- Don't forget to unblock async exceptions in the handler, or if we're
1741 -- in an exception loop (eg. let a = error a in a) the ^C exception
1742 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1744 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1745 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1747 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1748 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1750 -- ----------------------------------------------------------------------------
1753 -- TODO: won't work if home dir is encoded.
1754 -- (changeDirectory may not work either in that case.)
1755 expandPath :: MonadIO m => String -> InputT m String
1756 expandPath path = do
1757 exp_path <- liftIO $ expandPathIO path
1758 enc <- fmap BS.unpack $ Encoding.encode exp_path
1761 expandPathIO :: String -> IO String
1763 case dropWhile isSpace path of
1765 tilde <- getHomeDirectory -- will fail if HOME not defined
1766 return (tilde ++ '/':d)
1770 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1771 wantInterpretedModule str = do
1772 modl <- lookupModule str
1773 dflags <- getDynFlags
1774 when (GHC.modulePackageId modl /= thisPackage dflags) $
1775 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1776 is_interpreted <- GHC.moduleIsInterpreted modl
1777 when (not is_interpreted) $
1778 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1781 wantNameFromInterpretedModule :: GHC.GhcMonad m
1782 => (Name -> SDoc -> m ())
1786 wantNameFromInterpretedModule noCanDo str and_then =
1787 handleSourceError (GHC.printExceptionAndWarnings) $ do
1788 names <- GHC.parseName str
1792 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1793 if not (GHC.isExternalName n)
1794 then noCanDo n $ ppr n <>
1795 text " is not defined in an interpreted module"
1797 is_interpreted <- GHC.moduleIsInterpreted modl
1798 if not is_interpreted
1799 then noCanDo n $ text "module " <> ppr modl <>
1800 text " is not interpreted"
1803 -- -----------------------------------------------------------------------------
1804 -- commands for debugger
1806 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1807 sprintCmd = pprintCommand False False
1808 printCmd = pprintCommand True False
1809 forceCmd = pprintCommand False True
1811 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1812 pprintCommand bind force str = do
1813 pprintClosureCommand bind force str
1815 stepCmd :: String -> GHCi ()
1816 stepCmd [] = doContinue (const True) GHC.SingleStep
1817 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1819 stepLocalCmd :: String -> GHCi ()
1820 stepLocalCmd [] = do
1821 mb_span <- getCurrentBreakSpan
1823 Nothing -> stepCmd []
1825 Just mod <- getCurrentBreakModule
1826 current_toplevel_decl <- enclosingTickSpan mod loc
1827 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1829 stepLocalCmd expression = stepCmd expression
1831 stepModuleCmd :: String -> GHCi ()
1832 stepModuleCmd [] = do
1833 mb_span <- getCurrentBreakSpan
1835 Nothing -> stepCmd []
1837 Just span <- getCurrentBreakSpan
1838 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1839 doContinue f GHC.SingleStep
1841 stepModuleCmd expression = stepCmd expression
1843 -- | Returns the span of the largest tick containing the srcspan given
1844 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1845 enclosingTickSpan mod src = do
1846 ticks <- getTickArray mod
1847 let line = srcSpanStartLine src
1848 ASSERT (inRange (bounds ticks) line) do
1849 let enclosing_spans = [ span | (_,span) <- ticks ! line
1850 , srcSpanEnd span >= srcSpanEnd src]
1851 return . head . sortBy leftmost_largest $ enclosing_spans
1853 traceCmd :: String -> GHCi ()
1854 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1855 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1857 continueCmd :: String -> GHCi ()
1858 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1860 -- doContinue :: SingleStep -> GHCi ()
1861 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1862 doContinue pred step = do
1863 runResult <- resume pred step
1864 _ <- afterRunStmt pred runResult
1867 abandonCmd :: String -> GHCi ()
1868 abandonCmd = noArgs $ do
1869 b <- GHC.abandon -- the prompt will change to indicate the new context
1870 when (not b) $ io $ putStrLn "There is no computation running."
1873 deleteCmd :: String -> GHCi ()
1874 deleteCmd argLine = do
1875 deleteSwitch $ words argLine
1877 deleteSwitch :: [String] -> GHCi ()
1879 io $ putStrLn "The delete command requires at least one argument."
1880 -- delete all break points
1881 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1882 deleteSwitch idents = do
1883 mapM_ deleteOneBreak idents
1885 deleteOneBreak :: String -> GHCi ()
1887 | all isDigit str = deleteBreak (read str)
1888 | otherwise = return ()
1890 historyCmd :: String -> GHCi ()
1892 | null arg = history 20
1893 | all isDigit arg = history (read arg)
1894 | otherwise = io $ putStrLn "Syntax: :history [num]"
1897 resumes <- GHC.getResumeContext
1899 [] -> io $ putStrLn "Not stopped at a breakpoint"
1901 let hist = GHC.resumeHistory r
1902 (took,rest) = splitAt num hist
1904 [] -> io $ putStrLn $
1905 "Empty history. Perhaps you forgot to use :trace?"
1907 spans <- mapM GHC.getHistorySpan took
1908 let nums = map (printf "-%-3d:") [(1::Int)..]
1909 names = map GHC.historyEnclosingDecl took
1910 printForUser (vcat(zipWith3
1911 (\x y z -> x <+> y <+> z)
1913 (map (bold . ppr) names)
1914 (map (parens . ppr) spans)))
1915 io $ putStrLn $ if null rest then "<end of history>" else "..."
1917 bold :: SDoc -> SDoc
1918 bold c | do_bold = text start_bold <> c <> text end_bold
1921 backCmd :: String -> GHCi ()
1922 backCmd = noArgs $ do
1923 (names, _, span) <- GHC.back
1924 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1925 printTypeOfNames names
1926 -- run the command set with ":set stop <cmd>"
1928 enqueueCommands [stop st]
1930 forwardCmd :: String -> GHCi ()
1931 forwardCmd = noArgs $ do
1932 (names, ix, span) <- GHC.forward
1933 printForUser $ (if (ix == 0)
1934 then ptext (sLit "Stopped at")
1935 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1936 printTypeOfNames names
1937 -- run the command set with ":set stop <cmd>"
1939 enqueueCommands [stop st]
1941 -- handle the "break" command
1942 breakCmd :: String -> GHCi ()
1943 breakCmd argLine = do
1944 breakSwitch $ words argLine
1946 breakSwitch :: [String] -> GHCi ()
1948 io $ putStrLn "The break command requires at least one argument."
1949 breakSwitch (arg1:rest)
1950 | looksLikeModuleName arg1 && not (null rest) = do
1951 mod <- wantInterpretedModule arg1
1952 breakByModule mod rest
1953 | all isDigit arg1 = do
1954 (toplevel, _) <- GHC.getContext
1956 (mod : _) -> breakByModuleLine mod (read arg1) rest
1958 io $ putStrLn "Cannot find default module for breakpoint."
1959 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1960 | otherwise = do -- try parsing it as an identifier
1961 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1962 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1963 if GHC.isGoodSrcLoc loc
1964 then ASSERT( isExternalName name )
1965 findBreakAndSet (GHC.nameModule name) $
1966 findBreakByCoord (Just (GHC.srcLocFile loc))
1967 (GHC.srcLocLine loc,
1969 else noCanDo name $ text "can't find its location: " <> ppr loc
1971 noCanDo n why = printForUser $
1972 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1974 breakByModule :: Module -> [String] -> GHCi ()
1975 breakByModule mod (arg1:rest)
1976 | all isDigit arg1 = do -- looks like a line number
1977 breakByModuleLine mod (read arg1) rest
1981 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1982 breakByModuleLine mod line args
1983 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1984 | [col] <- args, all isDigit col =
1985 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1986 | otherwise = breakSyntax
1989 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1991 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1992 findBreakAndSet mod lookupTickTree = do
1993 tickArray <- getTickArray mod
1994 (breakArray, _) <- getModBreak mod
1995 case lookupTickTree tickArray of
1996 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1997 Just (tick, span) -> do
1998 success <- io $ setBreakFlag True breakArray tick
2002 recordBreak $ BreakLocation
2009 text "Breakpoint " <> ppr nm <>
2011 then text " was already set at " <> ppr span
2012 else text " activated at " <> ppr span
2014 printForUser $ text "Breakpoint could not be activated at"
2017 -- When a line number is specified, the current policy for choosing
2018 -- the best breakpoint is this:
2019 -- - the leftmost complete subexpression on the specified line, or
2020 -- - the leftmost subexpression starting on the specified line, or
2021 -- - the rightmost subexpression enclosing the specified line
2023 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2024 findBreakByLine line arr
2025 | not (inRange (bounds arr) line) = Nothing
2027 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2028 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2029 listToMaybe (sortBy (rightmost `on` snd) ticks)
2033 starts_here = [ tick | tick@(_,span) <- ticks,
2034 GHC.srcSpanStartLine span == line ]
2036 (complete,incomplete) = partition ends_here starts_here
2037 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2039 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2040 -> Maybe (BreakIndex,SrcSpan)
2041 findBreakByCoord mb_file (line, col) arr
2042 | not (inRange (bounds arr) line) = Nothing
2044 listToMaybe (sortBy (rightmost `on` snd) contains ++
2045 sortBy (leftmost_smallest `on` snd) after_here)
2049 -- the ticks that span this coordinate
2050 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2051 is_correct_file span ]
2053 is_correct_file span
2054 | Just f <- mb_file = GHC.srcSpanFile span == f
2057 after_here = [ tick | tick@(_,span) <- ticks,
2058 GHC.srcSpanStartLine span == line,
2059 GHC.srcSpanStartCol span >= col ]
2061 -- For now, use ANSI bold on terminals that we know support it.
2062 -- Otherwise, we add a line of carets under the active expression instead.
2063 -- In particular, on Windows and when running the testsuite (which sets
2064 -- TERM to vt100 for other reasons) we get carets.
2065 -- We really ought to use a proper termcap/terminfo library.
2067 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2068 where mTerm = System.Environment.getEnv "TERM"
2069 `catchIO` \_ -> return "TERM not set"
2071 start_bold :: String
2072 start_bold = "\ESC[1m"
2074 end_bold = "\ESC[0m"
2076 listCmd :: String -> InputT GHCi ()
2078 mb_span <- lift getCurrentBreakSpan
2081 printForUser $ text "Not stopped at a breakpoint; nothing to list"
2083 | GHC.isGoodSrcSpan span -> listAround span True
2085 do resumes <- GHC.getResumeContext
2087 [] -> panic "No resumes"
2089 do let traceIt = case GHC.resumeHistory r of
2090 [] -> text "rerunning with :trace,"
2092 doWhat = traceIt <+> text ":back then :list"
2093 printForUser (text "Unable to list source for" <+>
2095 $$ text "Try" <+> doWhat)
2096 listCmd str = list2 (words str)
2098 list2 :: [String] -> InputT GHCi ()
2099 list2 [arg] | all isDigit arg = do
2100 (toplevel, _) <- GHC.getContext
2102 [] -> outputStrLn "No module to list"
2103 (mod : _) -> listModuleLine mod (read arg)
2104 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2105 mod <- wantInterpretedModule arg1
2106 listModuleLine mod (read arg2)
2108 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2109 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2110 if GHC.isGoodSrcLoc loc
2112 tickArray <- ASSERT( isExternalName name )
2113 lift $ getTickArray (GHC.nameModule name)
2114 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2115 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2118 Nothing -> listAround (GHC.srcLocSpan loc) False
2119 Just (_,span) -> listAround span False
2121 noCanDo name $ text "can't find its location: " <>
2124 noCanDo n why = printForUser $
2125 text "cannot list source code for " <> ppr n <> text ": " <> why
2127 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2129 listModuleLine :: Module -> Int -> InputT GHCi ()
2130 listModuleLine modl line = do
2131 graph <- GHC.getModuleGraph
2132 let this = filter ((== modl) . GHC.ms_mod) graph
2134 [] -> panic "listModuleLine"
2136 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2137 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2138 listAround (GHC.srcLocSpan loc) False
2140 -- | list a section of a source file around a particular SrcSpan.
2141 -- If the highlight flag is True, also highlight the span using
2142 -- start_bold\/end_bold.
2144 -- GHC files are UTF-8, so we can implement this by:
2145 -- 1) read the file in as a BS and syntax highlight it as before
2146 -- 2) convert the BS to String using utf-string, and write it out.
2147 -- It would be better if we could convert directly between UTF-8 and the
2148 -- console encoding, of course.
2149 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2150 listAround span do_highlight = do
2151 contents <- liftIO $ BS.readFile (unpackFS file)
2153 lines = BS.split '\n' contents
2154 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2155 drop (line1 - 1 - pad_before) $ lines
2156 fst_line = max 1 (line1 - pad_before)
2157 line_nos = [ fst_line .. ]
2159 highlighted | do_highlight = zipWith highlight line_nos these_lines
2160 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2162 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2163 prefixed = zipWith ($) highlighted bs_line_nos
2165 let output = BS.intercalate (BS.pack "\n") prefixed
2166 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2167 $ \(p,n) -> utf8DecodeString (castPtr p) n
2168 outputStrLn utf8Decoded
2170 file = GHC.srcSpanFile span
2171 line1 = GHC.srcSpanStartLine span
2172 col1 = GHC.srcSpanStartCol span - 1
2173 line2 = GHC.srcSpanEndLine span
2174 col2 = GHC.srcSpanEndCol span - 1
2176 pad_before | line1 == 1 = 0
2180 highlight | do_bold = highlight_bold
2181 | otherwise = highlight_carets
2183 highlight_bold no line prefix
2184 | no == line1 && no == line2
2185 = let (a,r) = BS.splitAt col1 line
2186 (b,c) = BS.splitAt (col2-col1) r
2188 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2190 = let (a,b) = BS.splitAt col1 line in
2191 BS.concat [prefix, a, BS.pack start_bold, b]
2193 = let (a,b) = BS.splitAt col2 line in
2194 BS.concat [prefix, a, BS.pack end_bold, b]
2195 | otherwise = BS.concat [prefix, line]
2197 highlight_carets no line prefix
2198 | no == line1 && no == line2
2199 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2200 BS.replicate (col2-col1) '^']
2202 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2205 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2207 | otherwise = BS.concat [prefix, line]
2209 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2210 nl = BS.singleton '\n'
2212 -- --------------------------------------------------------------------------
2215 getTickArray :: Module -> GHCi TickArray
2216 getTickArray modl = do
2218 let arrmap = tickarrays st
2219 case lookupModuleEnv arrmap modl of
2220 Just arr -> return arr
2222 (_breakArray, ticks) <- getModBreak modl
2223 let arr = mkTickArray (assocs ticks)
2224 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2227 discardTickArrays :: GHCi ()
2228 discardTickArrays = do
2230 setGHCiState st{tickarrays = emptyModuleEnv}
2232 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2234 = accumArray (flip (:)) [] (1, max_line)
2235 [ (line, (nm,span)) | (nm,span) <- ticks,
2236 line <- srcSpanLines span ]
2238 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2239 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2240 GHC.srcSpanEndLine span ]
2242 lookupModule :: GHC.GhcMonad m => String -> m Module
2243 lookupModule modName
2244 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2246 -- don't reset the counter back to zero?
2247 discardActiveBreakPoints :: GHCi ()
2248 discardActiveBreakPoints = do
2250 mapM_ (turnOffBreak.snd) (breaks st)
2251 setGHCiState $ st { breaks = [] }
2253 deleteBreak :: Int -> GHCi ()
2254 deleteBreak identity = do
2256 let oldLocations = breaks st
2257 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2259 then printForUser (text "Breakpoint" <+> ppr identity <+>
2260 text "does not exist")
2262 mapM_ (turnOffBreak.snd) this
2263 setGHCiState $ st { breaks = rest }
2265 turnOffBreak :: BreakLocation -> GHCi Bool
2266 turnOffBreak loc = do
2267 (arr, _) <- getModBreak (breakModule loc)
2268 io $ setBreakFlag False arr (breakTick loc)
2270 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2271 getModBreak mod = do
2272 Just mod_info <- GHC.getModuleInfo mod
2273 let modBreaks = GHC.modInfoModBreaks mod_info
2274 let array = GHC.modBreaks_flags modBreaks
2275 let ticks = GHC.modBreaks_locs modBreaks
2276 return (array, ticks)
2278 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2279 setBreakFlag toggle array index
2280 | toggle = GHC.setBreakOn array index
2281 | otherwise = GHC.setBreakOff array index