1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 {-# OPTIONS -#include "Linker.h" #-}
5 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6 -----------------------------------------------------------------------------
8 -- GHC Interactive User Interface
10 -- (c) The GHC Team 2005-2006
12 -----------------------------------------------------------------------------
14 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
16 #include "HsVersions.h"
18 import qualified GhciMonad
19 import GhciMonad hiding (runStmt)
24 import qualified GHC hiding (resume, runStmt)
25 import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
27 BreakIndex, Resume, SingleStep,
28 Ghc, handleSourceError )
33 -- import PackageConfig
36 import HscTypes ( implicitTyThings, handleFlagWarnings )
37 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
38 import Outputable hiding (printForUser, printForUserPartWay)
39 import Module -- for ModuleEnv
43 -- Other random utilities
46 import BasicTypes hiding (isTopLevel)
47 import Panic hiding (showException)
53 import Maybes ( orElse, expectJust )
58 #ifndef mingw32_HOST_OS
59 import System.Posix hiding (getEnv)
61 import qualified System.Win32
64 import System.Console.Haskeline as Haskeline
65 import qualified System.Console.Haskeline.Encoding as Encoding
66 import Control.Monad.Trans
70 import Exception hiding (catch, block, unblock)
72 -- import Control.Concurrent
74 import System.FilePath
75 import qualified Data.ByteString.Char8 as BS
79 import System.Environment
80 import System.Exit ( exitWith, ExitCode(..) )
81 import System.Directory
83 import System.IO.Error as IO
86 import Control.Monad as Monad
89 import GHC.Exts ( unsafeCoerce# )
91 #if __GLASGOW_HASKELL__ >= 611
92 import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
93 import GHC.IO.Handle ( hFlushAll )
95 import GHC.IOBase ( IOErrorType(InvalidArgument) )
100 import Data.IORef ( IORef, readIORef, writeIORef )
102 -----------------------------------------------------------------------------
104 ghciWelcomeMsg :: String
105 ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
106 ": http://www.haskell.org/ghc/ :? for help"
108 cmdName :: Command -> String
111 GLOBAL_VAR(macros_ref, [], [Command])
113 builtin_commands :: [Command]
115 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
116 ("?", keepGoing help, noCompletion),
117 ("add", keepGoingPaths addModule, completeFilename),
118 ("abandon", keepGoing abandonCmd, noCompletion),
119 ("break", keepGoing breakCmd, completeIdentifier),
120 ("back", keepGoing backCmd, noCompletion),
121 ("browse", keepGoing' (browseCmd False), completeModule),
122 ("browse!", keepGoing' (browseCmd True), completeModule),
123 ("cd", keepGoing' changeDirectory, completeFilename),
124 ("check", keepGoing' checkModule, completeHomeModule),
125 ("continue", keepGoing continueCmd, noCompletion),
126 ("cmd", keepGoing cmdCmd, completeExpression),
127 ("ctags", keepGoing createCTagsFileCmd, completeFilename),
128 ("def", keepGoing (defineMacro False), completeExpression),
129 ("def!", keepGoing (defineMacro True), completeExpression),
130 ("delete", keepGoing deleteCmd, noCompletion),
131 ("e", keepGoing editFile, completeFilename),
132 ("edit", keepGoing editFile, completeFilename),
133 ("etags", keepGoing createETagsFileCmd, completeFilename),
134 ("force", keepGoing forceCmd, completeExpression),
135 ("forward", keepGoing forwardCmd, noCompletion),
136 ("help", keepGoing help, noCompletion),
137 ("history", keepGoing historyCmd, noCompletion),
138 ("info", keepGoing' info, completeIdentifier),
139 ("kind", keepGoing' kindOfType, completeIdentifier),
140 ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
141 ("list", keepGoing' listCmd, noCompletion),
142 ("module", keepGoing setContext, completeModule),
143 ("main", keepGoing runMain, completeFilename),
144 ("print", keepGoing printCmd, completeExpression),
145 ("quit", quit, noCompletion),
146 ("reload", keepGoing' reloadModule, noCompletion),
147 ("run", keepGoing runRun, completeFilename),
148 ("set", keepGoing setCmd, completeSetOptions),
149 ("show", keepGoing showCmd, completeShowOptions),
150 ("sprint", keepGoing sprintCmd, completeExpression),
151 ("step", keepGoing stepCmd, completeIdentifier),
152 ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
153 ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
154 ("type", keepGoing' typeOfExpr, completeExpression),
155 ("trace", keepGoing traceCmd, completeExpression),
156 ("undef", keepGoing undefineMacro, completeMacro),
157 ("unset", keepGoing unsetOptions, completeSetOptions)
161 -- We initialize readline (in the interactiveUI function) to use
162 -- word_break_chars as the default set of completion word break characters.
163 -- This can be overridden for a particular command (for example, filename
164 -- expansion shouldn't consider '/' to be a word break) by setting the third
165 -- entry in the Command tuple above.
167 -- NOTE: in order for us to override the default correctly, any custom entry
168 -- must be a SUBSET of word_break_chars.
169 word_break_chars :: String
170 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
171 specials = "(),;[]`{}"
173 in spaces ++ specials ++ symbols
175 flagWordBreakChars :: String
176 flagWordBreakChars = " \t\n"
179 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
180 keepGoing a str = keepGoing' (lift . a) str
182 keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
183 keepGoing' a str = a str >> return False
185 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
187 = do case toArgs str of
188 Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr
192 shortHelpText :: String
193 shortHelpText = "use :? for help.\n"
197 " Commands available from the prompt:\n" ++
199 " <statement> evaluate/run <statement>\n" ++
200 " : repeat last command\n" ++
201 " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
202 " :add [*]<module> ... add module(s) to the current target set\n" ++
203 " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
204 " (!: more details; *: all top-level names)\n" ++
205 " :cd <dir> change directory to <dir>\n" ++
206 " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
207 " :ctags [<file>] create tags file for Vi (default: \"tags\")\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
332 -- initial context is just the Prelude
333 prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
334 GHC.setContext [] [prel_mod]
336 default_editor <- liftIO $ findEditor
338 startGHCi (runGHCi srcs maybe_exprs)
339 GHCiState{ progname = "<interactive>",
343 editor = default_editor,
344 -- session = session,
349 tickarrays = emptyModuleEnv,
350 last_command = Nothing,
353 ghc_e = isJust maybe_exprs
358 withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
359 withGhcAppData right left = do
360 either_dir <- IO.try (getAppUserDataDirectory "ghc")
362 Right dir -> right dir
365 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
366 runGHCi paths maybe_exprs = do
368 read_dot_files = not opt_IgnoreDotGhci
370 current_dir = return (Just ".ghci")
372 app_user_dir = io $ withGhcAppData
373 (\dir -> return (Just (dir </> "ghci.conf")))
377 either_dir <- io $ IO.try (getEnv "HOME")
379 Right home -> return (Just (home </> ".ghci"))
382 sourceConfigFile :: FilePath -> GHCi ()
383 sourceConfigFile file = do
384 exists <- io $ doesFileExist file
386 dir_ok <- io $ checkPerms (getDirectory file)
387 file_ok <- io $ checkPerms file
388 when (dir_ok && file_ok) $ do
389 either_hdl <- io $ IO.try (openFile file ReadMode)
392 -- NOTE: this assumes that runInputT won't affect the terminal;
393 -- can we assume this will always be the case?
394 -- This would be a good place for runFileInputT.
395 Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do
397 runCommands $ fileLoop hdl
399 getDirectory f = case takeDirectory f of "" -> "."; d -> d
401 when (read_dot_files) $ do
402 cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
403 cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
404 mapM_ sourceConfigFile (nub cfgs)
405 -- nub, because we don't want to read .ghci twice if the
408 -- Perform a :load for files given on the GHCi command line
409 -- When in -e mode, if the load fails then we want to stop
410 -- immediately rather than going on to evaluate the expression.
411 when (not (null paths)) $ do
412 ok <- ghciHandle (\e -> do showException e; return Failed) $
413 -- TODO: this is a hack.
414 runInputTWithPrefs defaultPrefs defaultSettings $ do
415 let (filePaths, phases) = unzip paths
416 filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
417 loadModule (zip filePaths' phases)
418 when (isJust maybe_exprs && failed ok) $
419 io (exitWith (ExitFailure 1))
421 -- if verbosity is greater than 0, or we are connected to a
422 -- terminal, display the prompt in the interactive loop.
423 is_tty <- io (hIsTerminalDevice stdin)
424 dflags <- getDynFlags
425 let show_prompt = verbosity dflags > 0 || is_tty
430 -- enter the interactive loop
431 runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
433 -- just evaluate the expression we were given
434 enqueueCommands exprs
435 let handle e = do st <- getGHCiState
436 -- Jump through some hoops to get the
437 -- current progname in the exception text:
438 -- <progname>: <exception>
439 io $ withProgName (progname st)
440 -- this used to be topHandlerFastExit, see #2228
442 runInputTWithPrefs defaultPrefs defaultSettings $ do
444 runCommands' handle (return Nothing)
447 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
449 runGHCiInput :: InputT GHCi a -> GHCi a
451 histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
453 let settings = setComplete ghciCompleteWord
454 $ defaultSettings {historyFile = histFile}
455 runInputT settings $ do
459 nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
460 nextInputLine show_prompt is_tty
462 prompt <- if show_prompt then lift mkPrompt else return ""
465 when show_prompt $ lift mkPrompt >>= liftIO . putStr
468 -- NOTE: We only read .ghci files if they are owned by the current user,
469 -- and aren't world writable. Otherwise, we could be accidentally
470 -- running code planted by a malicious third party.
472 -- Furthermore, We only read ./.ghci if . is owned by the current user
473 -- and isn't writable by anyone else. I think this is sufficient: we
474 -- don't need to check .. and ../.. etc. because "." always refers to
475 -- the same directory while a process is running.
477 checkPerms :: String -> IO Bool
478 #ifdef mingw32_HOST_OS
483 handleIO (\_ -> return False) $ do
484 st <- getFileStatus name
486 if fileOwner st /= me then do
487 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
490 let mode = fileMode st
491 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
492 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
494 putStrLn $ "*** WARNING: " ++ name ++
495 " is writable by someone else, IGNORING!"
500 fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
502 l <- liftIO $ IO.try $ hGetLine hdl
504 Left e | isEOFError e -> return Nothing
505 | InvalidArgument <- etype -> return Nothing
506 | otherwise -> liftIO $ ioError e
507 where etype = ioeGetErrorType e
508 -- treat InvalidArgument in the same way as EOF:
509 -- this can happen if the user closed stdin, or
510 -- perhaps did getContents which closes stdin at
512 Right l -> return (Just l)
514 mkPrompt :: GHCi String
516 (toplevs,exports) <- GHC.getContext
517 resumes <- GHC.getResumeContext
518 -- st <- getGHCiState
524 let ix = GHC.resumeHistoryIx r
526 then return (brackets (ppr (GHC.resumeSpan r)) <> space)
528 let hist = GHC.resumeHistory r !! (ix-1)
529 span <- GHC.getHistorySpan hist
530 return (brackets (ppr (negate ix) <> char ':'
531 <+> ppr span) <> space)
533 dots | _:rs <- resumes, not (null rs) = text "... "
540 -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
541 -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
542 -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
543 hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
544 hsep (map (ppr . GHC.moduleName) exports)
546 deflt_prompt = dots <> context_bit <> modules_bit
548 f ('%':'s':xs) = deflt_prompt <> f xs
549 f ('%':'%':xs) = char '%' <> f xs
550 f (x:xs) = char x <> f xs
554 return (showSDoc (f (prompt st)))
557 queryQueue :: GHCi (Maybe String)
562 c:cs -> do setGHCiState st{ cmdqueue = cs }
565 runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
566 runCommands = runCommands' handler
568 runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
569 -> InputT GHCi (Maybe String) -> InputT GHCi ()
570 runCommands' eh getCmd = do
571 b <- handleGhcException (\e -> case e of
572 Interrupted -> return False
573 _other -> liftIO (print e) >> return True)
574 (runOneCommand eh getCmd)
575 if b then return () else runCommands' eh getCmd
577 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
579 runOneCommand eh getCmd = do
580 mb_cmd <- noSpace (lift queryQueue)
581 mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
583 Nothing -> return True
584 Just c -> ghciHandle (lift . eh) $
585 handleSourceError printErrorAndKeepGoing
588 printErrorAndKeepGoing err = do
589 GHC.printExceptionAndWarnings err
592 noSpace q = q >>= maybe (return Nothing)
593 (\c->case removeSpaces c of
595 ":{" -> multiLineCmd q
596 c -> return (Just c) )
598 st <- lift getGHCiState
600 lift $ setGHCiState st{ prompt = "%s| " }
601 mb_cmd <- collectCommand q ""
602 lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
604 -- we can't use removeSpaces for the sublines here, so
605 -- multiline commands are somewhat more brittle against
606 -- fileformat errors (such as \r in dos input on unix),
607 -- we get rid of any extra spaces for the ":}" test;
608 -- we also avoid silent failure if ":}" is not found;
609 -- and since there is no (?) valid occurrence of \r (as
610 -- opposed to its String representation, "\r") inside a
611 -- ghci command, we replace any such with ' ' (argh:-(
612 collectCommand q c = q >>=
613 maybe (liftIO (ioError collectError))
614 (\l->if removeSpaces l == ":}"
615 then return (Just $ removeSpaces c)
616 else collectCommand q (c++map normSpace l))
617 where normSpace '\r' = ' '
619 -- QUESTION: is userError the one to use here?
620 collectError = userError "unterminated multiline command :{ .. :}"
621 doCommand (':' : cmd) = specialCommand cmd
622 doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
625 enqueueCommands :: [String] -> GHCi ()
626 enqueueCommands cmds = do
628 setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
631 runStmt :: String -> SingleStep -> GHCi Bool
633 | null (filter (not.isSpace) stmt) = return False
634 | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
637 #if __GLASGOW_HASKELL__ >= 611
638 -- In the new IO library, read handles buffer data even if the Handle
639 -- is set to NoBuffering. This causes problems for GHCi where there
640 -- are really two stdin Handles. So we flush any bufferred data in
641 -- GHCi's stdin Handle here (only relevant if stdin is attached to
642 -- a file, otherwise the read buffer can't be flushed).
643 _ <- liftIO $ IO.try $ hFlushAll stdin
645 result <- GhciMonad.runStmt stmt step
646 afterRunStmt (const True) result
648 --afterRunStmt :: GHC.RunResult -> GHCi Bool
649 -- False <=> the statement failed to compile
650 afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
651 afterRunStmt _ (GHC.RunException e) = throw e
652 afterRunStmt step_here run_result = do
653 resumes <- GHC.getResumeContext
655 GHC.RunOk names -> do
656 show_types <- isOptionSet ShowType
657 when show_types $ printTypeOfNames names
658 GHC.RunBreak _ names mb_info
659 | isNothing mb_info ||
660 step_here (GHC.resumeSpan $ head resumes) -> do
661 mb_id_loc <- toBreakIdAndLocation mb_info
662 let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
664 then printStoppedAtBreakInfo (head resumes) names
665 else enqueueCommands [breakCmd]
666 -- run the command set with ":set stop <cmd>"
668 enqueueCommands [stop st]
670 | otherwise -> resume step_here GHC.SingleStep >>=
671 afterRunStmt step_here >> return ()
675 io installSignalHandlers
676 b <- isOptionSet RevertCAFs
679 return (case run_result of GHC.RunOk _ -> True; _ -> False)
681 toBreakIdAndLocation ::
682 Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
683 toBreakIdAndLocation Nothing = return Nothing
684 toBreakIdAndLocation (Just info) = do
685 let mod = GHC.breakInfo_module info
686 nm = GHC.breakInfo_number info
688 return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
689 breakModule loc == mod,
690 breakTick loc == nm ]
692 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
693 printStoppedAtBreakInfo resume names = do
694 printForUser $ ptext (sLit "Stopped at") <+>
695 ppr (GHC.resumeSpan resume)
696 -- printTypeOfNames session names
697 let namesSorted = sortBy compareNames names
698 tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
699 docs <- pprTypeAndContents [id | AnId id <- tythings]
700 printForUserPartWay docs
702 printTypeOfNames :: [Name] -> GHCi ()
703 printTypeOfNames names
704 = mapM_ (printTypeOfName ) $ sortBy compareNames names
706 compareNames :: Name -> Name -> Ordering
707 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
708 where compareWith n = (getOccString n, getSrcSpan n)
710 printTypeOfName :: Name -> GHCi ()
712 = do maybe_tything <- GHC.lookupName n
713 case maybe_tything of
715 Just thing -> printTyThing thing
718 data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
720 specialCommand :: String -> InputT GHCi Bool
721 specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
722 specialCommand str = do
723 let (cmd,rest) = break isSpace str
724 maybe_cmd <- lift $ lookupCommand cmd
726 GotCommand (_,f,_) -> f (dropWhile isSpace rest)
728 do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
732 do liftIO $ hPutStr stdout ("there is no last command to perform\n"
736 lookupCommand :: String -> GHCi (MaybeCommand)
737 lookupCommand "" = do
739 case last_command st of
740 Just c -> return $ GotCommand c
741 Nothing -> return NoLastCommand
742 lookupCommand str = do
743 mc <- io $ lookupCommand' str
745 setGHCiState st{ last_command = mc }
747 Just c -> GotCommand c
748 Nothing -> BadCommand
750 lookupCommand' :: String -> IO (Maybe Command)
751 lookupCommand' str = do
752 macros <- readIORef macros_ref
753 let cmds = builtin_commands ++ macros
754 -- look for exact match first, then the first prefix match
755 return $ case [ c | c <- cmds, str == cmdName c ] of
757 [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
761 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
762 getCurrentBreakSpan = do
763 resumes <- GHC.getResumeContext
767 let ix = GHC.resumeHistoryIx r
769 then return (Just (GHC.resumeSpan r))
771 let hist = GHC.resumeHistory r !! (ix-1)
772 span <- GHC.getHistorySpan hist
775 getCurrentBreakModule :: GHCi (Maybe Module)
776 getCurrentBreakModule = do
777 resumes <- GHC.getResumeContext
781 let ix = GHC.resumeHistoryIx r
783 then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
785 let hist = GHC.resumeHistory r !! (ix-1)
786 return $ Just $ GHC.getHistoryModule hist
788 -----------------------------------------------------------------------------
791 noArgs :: GHCi () -> String -> GHCi ()
793 noArgs _ _ = io $ putStrLn "This command takes no arguments"
795 help :: String -> GHCi ()
796 help _ = io (putStr helpText)
798 info :: String -> InputT GHCi ()
799 info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
800 info s = handleSourceError GHC.printExceptionAndWarnings $ do
801 { let names = words s
802 ; dflags <- getDynFlags
803 ; let pefas = dopt Opt_PrintExplicitForalls dflags
804 ; mapM_ (infoThing pefas) names }
806 infoThing pefas str = do
807 names <- GHC.parseName str
808 mb_stuffs <- mapM GHC.getInfo names
809 let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
810 unqual <- GHC.getPrintUnqual
811 outputStrLn $ showSDocForUser unqual $
812 vcat (intersperse (text "") $
813 map (pprInfo pefas) filtered)
815 -- Filter out names whose parent is also there Good
816 -- example is '[]', which is both a type and data
817 -- constructor in the same type
818 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
819 filterOutChildren get_thing xs
820 = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
822 implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
824 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
825 pprInfo pefas (thing, fixity, insts)
826 = pprTyThingInContextLoc pefas thing
827 $$ show_fixity fixity
828 $$ vcat (map GHC.pprInstance insts)
831 | fix == GHC.defaultFixity = empty
832 | otherwise = ppr fix <+> ppr (GHC.getName thing)
834 runMain :: String -> GHCi ()
835 runMain s = case toArgs s of
836 Left err -> io (hPutStrLn stderr err)
838 do dflags <- getDynFlags
839 case mainFunIs dflags of
840 Nothing -> doWithArgs args "main"
841 Just f -> doWithArgs args f
843 runRun :: String -> GHCi ()
844 runRun s = case toCmdArgs s of
845 Left err -> io (hPutStrLn stderr err)
846 Right (cmd, args) -> doWithArgs args cmd
848 doWithArgs :: [String] -> String -> GHCi ()
849 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
850 show args ++ " (" ++ cmd ++ ")"]
852 addModule :: [FilePath] -> InputT GHCi ()
854 lift revertCAFs -- always revert CAFs on load/add.
855 files <- mapM expandPath files
856 targets <- mapM (\m -> GHC.guessTarget m Nothing) files
857 -- remove old targets with the same id; e.g. for :add *M
858 mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
859 mapM_ GHC.addTarget targets
860 prev_context <- GHC.getContext
861 ok <- trySuccess $ GHC.load LoadAllTargets
862 afterLoad ok False prev_context
864 changeDirectory :: String -> InputT GHCi ()
865 changeDirectory "" = do
866 -- :cd on its own changes to the user's home directory
867 either_dir <- liftIO $ IO.try getHomeDirectory
870 Right dir -> changeDirectory dir
871 changeDirectory dir = do
872 graph <- GHC.getModuleGraph
873 when (not (null graph)) $
874 outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
875 prev_context <- GHC.getContext
877 _ <- GHC.load LoadAllTargets
878 lift $ setContextAfterLoad prev_context False []
879 GHC.workingDirectoryChanged
880 dir <- expandPath dir
881 liftIO $ setCurrentDirectory dir
883 trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
885 handleSourceError (\e -> do GHC.printExceptionAndWarnings e
889 editFile :: String -> GHCi ()
891 do file <- if null str then chooseEditFile else return str
895 $ ghcError (CmdLineError "editor not set, use :set editor")
896 _ <- io $ system (cmd ++ ' ':file)
899 -- The user didn't specify a file so we pick one for them.
900 -- Our strategy is to pick the first module that failed to load,
901 -- or otherwise the first target.
903 -- XXX: Can we figure out what happened if the depndecy analysis fails
904 -- (e.g., because the porgrammeer mistyped the name of a module)?
905 -- XXX: Can we figure out the location of an error to pass to the editor?
906 -- XXX: if we could figure out the list of errors that occured during the
907 -- last load/reaload, then we could start the editor focused on the first
909 chooseEditFile :: GHCi String
911 do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
913 graph <- GHC.getModuleGraph
914 failed_graph <- filterM hasFailed graph
915 let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
917 x : _ -> GHC.ml_hs_file (GHC.ms_location x)
920 case pick (order failed_graph) of
921 Just file -> return file
923 do targets <- GHC.getTargets
924 case msum (map fromTarget targets) of
925 Just file -> return file
926 Nothing -> ghcError (CmdLineError "No files to edit.")
928 where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
929 fromTarget _ = Nothing -- when would we get a module target?
931 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
932 defineMacro overwrite s = do
933 let (macro_name, definition) = break isSpace s
934 macros <- io (readIORef macros_ref)
935 let defined = map cmdName macros
938 then io $ putStrLn "no macros defined"
939 else io $ putStr ("the following macros are defined:\n" ++
942 if (not overwrite && macro_name `elem` defined)
943 then ghcError (CmdLineError
944 ("macro '" ++ macro_name ++ "' is already defined"))
947 let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
949 -- give the expression a type signature, so we can be sure we're getting
950 -- something of the right type.
951 let new_expr = '(' : definition ++ ") :: String -> IO String"
953 -- compile the expression
954 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
955 hv <- GHC.compileExpr new_expr
956 io (writeIORef macros_ref --
957 (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
959 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
961 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
962 -- make sure we force any exceptions in the result, while we are still
963 -- inside the exception handler for commands:
964 seqList str (return ())
965 enqueueCommands (lines str)
968 undefineMacro :: String -> GHCi ()
969 undefineMacro str = mapM_ undef (words str)
970 where undef macro_name = do
971 cmds <- io (readIORef macros_ref)
972 if (macro_name `notElem` map cmdName cmds)
973 then ghcError (CmdLineError
974 ("macro '" ++ macro_name ++ "' is not defined"))
976 io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
978 cmdCmd :: String -> GHCi ()
980 let expr = '(' : str ++ ") :: IO String"
981 handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
982 hv <- GHC.compileExpr expr
983 cmds <- io $ (unsafeCoerce# hv :: IO String)
984 enqueueCommands (lines cmds)
987 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
988 loadModule fs = timeIt (loadModule' fs)
990 loadModule_ :: [FilePath] -> InputT GHCi ()
991 loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
993 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
994 loadModule' files = do
995 prev_context <- GHC.getContext
999 lift discardActiveBreakPoints
1001 _ <- GHC.load LoadAllTargets
1003 let (filenames, phases) = unzip files
1004 exp_filenames <- mapM expandPath filenames
1005 let files' = zip exp_filenames phases
1006 targets <- mapM (uncurry GHC.guessTarget) files'
1008 -- NOTE: we used to do the dependency anal first, so that if it
1009 -- fails we didn't throw away the current set of modules. This would
1010 -- require some re-working of the GHC interface, so we'll leave it
1011 -- as a ToDo for now.
1013 GHC.setTargets targets
1014 doLoad False prev_context LoadAllTargets
1016 checkModule :: String -> InputT GHCi ()
1018 let modl = GHC.mkModuleName m
1019 prev_context <- GHC.getContext
1020 ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
1021 r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
1022 outputStrLn (showSDoc (
1023 case GHC.moduleInfo r of
1024 cm | Just scope <- GHC.modInfoTopLevelScope cm ->
1026 (local,global) = ASSERT( all isExternalName scope )
1027 partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
1029 (text "global names: " <+> ppr global) $$
1030 (text "local names: " <+> ppr local)
1033 afterLoad (successIf ok) False prev_context
1035 reloadModule :: String -> InputT GHCi ()
1037 prev_context <- GHC.getContext
1038 _ <- doLoad True prev_context $
1039 if null m then LoadAllTargets
1040 else LoadUpTo (GHC.mkModuleName m)
1043 doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
1044 doLoad retain_context prev_context howmuch = do
1045 -- turn off breakpoints before we load: we can't turn them off later, because
1046 -- the ModBreaks will have gone away.
1047 lift discardActiveBreakPoints
1048 ok <- trySuccess $ GHC.load howmuch
1049 afterLoad ok retain_context prev_context
1052 afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
1053 afterLoad ok retain_context prev_context = do
1054 lift revertCAFs -- always revert CAFs on load.
1055 lift discardTickArrays
1056 loaded_mod_summaries <- getLoadedModules
1057 let loaded_mods = map GHC.ms_mod loaded_mod_summaries
1058 loaded_mod_names = map GHC.moduleName loaded_mods
1059 modulesLoadedMsg ok loaded_mod_names
1061 lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
1064 setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
1065 setContextAfterLoad prev keep_ctxt [] = do
1066 prel_mod <- getPrelude
1067 setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
1068 setContextAfterLoad prev keep_ctxt ms = do
1069 -- load a target if one is available, otherwise load the topmost module.
1070 targets <- GHC.getTargets
1071 case [ m | Just m <- map (findTarget ms) targets ] of
1073 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1074 load_this (last graph')
1079 = case filter (`matches` t) ms of
1083 summary `matches` Target (TargetModule m) _ _
1084 = GHC.ms_mod_name summary == m
1085 summary `matches` Target (TargetFile f _) _ _
1086 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
1090 load_this summary | m <- GHC.ms_mod summary = do
1091 b <- GHC.moduleIsInterpreted m
1092 if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
1094 prel_mod <- getPrelude
1095 setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
1097 -- | Keep any package modules (except Prelude) when changing the context.
1098 setContextKeepingPackageModules
1099 :: ([Module],[Module]) -- previous context
1100 -> Bool -- re-execute :module commands
1101 -> ([Module],[Module]) -- new context
1103 setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
1104 let (_,bs0) = prev_context
1105 prel_mod <- getPrelude
1106 let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
1107 let bs1 = if null as then nub (prel_mod : bs) else bs
1108 GHC.setContext as (nub (bs1 ++ pkg_modules))
1112 mapM_ (playCtxtCmd False) (remembered_ctx st)
1115 setGHCiState st{ remembered_ctx = [] }
1117 isHomeModule :: Module -> Bool
1118 isHomeModule mod = GHC.modulePackageId mod == mainPackageId
1120 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
1121 modulesLoadedMsg ok mods = do
1122 dflags <- getDynFlags
1123 when (verbosity dflags > 0) $ do
1125 | null mods = text "none."
1126 | otherwise = hsep (
1127 punctuate comma (map ppr mods)) <> text "."
1130 outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
1132 outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
1135 typeOfExpr :: String -> InputT GHCi ()
1137 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1138 ty <- GHC.exprType str
1139 dflags <- getDynFlags
1140 let pefas = dopt Opt_PrintExplicitForalls dflags
1141 printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
1143 kindOfType :: String -> InputT GHCi ()
1145 = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
1146 ty <- GHC.typeKind str
1147 printForUser' $ text str <+> dcolon <+> ppr ty
1149 quit :: String -> InputT GHCi Bool
1150 quit _ = return True
1152 shellEscape :: String -> GHCi Bool
1153 shellEscape str = io (system str >> return False)
1155 -----------------------------------------------------------------------------
1156 -- Browsing a module's contents
1158 browseCmd :: Bool -> String -> InputT GHCi ()
1161 ['*':s] | looksLikeModuleName s -> do
1162 m <- lift $ wantInterpretedModule s
1163 browseModule bang m False
1164 [s] | looksLikeModuleName s -> do
1165 m <- lift $ lookupModule s
1166 browseModule bang m True
1168 (as,bs) <- GHC.getContext
1169 -- Guess which module the user wants to browse. Pick
1170 -- modules that are interpreted first. The most
1171 -- recently-added module occurs last, it seems.
1173 (as@(_:_), _) -> browseModule bang (last as) True
1174 ([], bs@(_:_)) -> browseModule bang (last bs) True
1175 ([], []) -> ghcError (CmdLineError ":browse: no current module")
1176 _ -> ghcError (CmdLineError "syntax: :browse <module>")
1178 -- without bang, show items in context of their parents and omit children
1179 -- with bang, show class methods and data constructors separately, and
1180 -- indicate import modules, to aid qualifying unqualified names
1181 -- with sorted, sort items alphabetically
1182 browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
1183 browseModule bang modl exports_only = do
1184 -- :browse! reports qualifiers wrt current context
1185 current_unqual <- GHC.getPrintUnqual
1186 -- Temporarily set the context to the module we're interested in,
1187 -- just so we can get an appropriate PrintUnqualified
1188 (as,bs) <- GHC.getContext
1189 prel_mod <- lift getPrelude
1190 if exports_only then GHC.setContext [] [prel_mod,modl]
1191 else GHC.setContext [modl] []
1192 target_unqual <- GHC.getPrintUnqual
1193 GHC.setContext as bs
1195 let unqual = if bang then current_unqual else target_unqual
1197 mb_mod_info <- GHC.getModuleInfo modl
1199 Nothing -> ghcError (CmdLineError ("unknown module: " ++
1200 GHC.moduleNameString (GHC.moduleName modl)))
1202 dflags <- getDynFlags
1204 | exports_only = GHC.modInfoExports mod_info
1205 | otherwise = GHC.modInfoTopLevelScope mod_info
1208 -- sort alphabetically name, but putting
1209 -- locally-defined identifiers first.
1210 -- We would like to improve this; see #1799.
1211 sorted_names = loc_sort local ++ occ_sort external
1213 (local,external) = ASSERT( all isExternalName names )
1214 partition ((==modl) . nameModule) names
1215 occ_sort = sortBy (compare `on` nameOccName)
1216 -- try to sort by src location. If the first name in
1217 -- our list has a good source location, then they all should.
1219 | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1220 = sortBy (compare `on` nameSrcSpan) names
1224 mb_things <- mapM GHC.lookupName sorted_names
1225 let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1227 rdr_env <- GHC.getGRE
1229 let pefas = dopt Opt_PrintExplicitForalls dflags
1230 things | bang = catMaybes mb_things
1231 | otherwise = filtered_things
1232 pretty | bang = pprTyThing
1233 | otherwise = pprTyThingInContext
1235 labels [] = text "-- not currently imported"
1236 labels l = text $ intercalate "\n" $ map qualifier l
1237 qualifier = maybe "-- defined locally"
1238 (("-- imported via "++) . intercalate ", "
1239 . map GHC.moduleNameString)
1240 importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1241 modNames = map (importInfo . GHC.getName) things
1243 -- annotate groups of imports with their import modules
1244 -- the default ordering is somewhat arbitrary, so we group
1245 -- by header and sort groups; the names themselves should
1246 -- really come in order of source appearance.. (trac #1799)
1247 annotate mts = concatMap (\(m,ts)->labels m:ts)
1248 $ sortBy cmpQualifiers $ group mts
1249 where cmpQualifiers =
1250 compare `on` (map (fmap (map moduleNameFS)) . fst)
1252 group mts@((m,_):_) = (m,map snd g) : group ng
1253 where (g,ng) = partition ((==m).fst) mts
1255 let prettyThings = map (pretty pefas) things
1256 prettyThings' | bang = annotate $ zip modNames prettyThings
1257 | otherwise = prettyThings
1258 outputStrLn $ showSDocForUser unqual (vcat prettyThings')
1259 -- ToDo: modInfoInstances currently throws an exception for
1260 -- package modules. When it works, we can do this:
1261 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1263 -----------------------------------------------------------------------------
1264 -- Setting the module context
1266 setContext :: String -> GHCi ()
1268 | all sensible strs = do
1269 playCtxtCmd True (cmd, as, bs)
1271 setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
1272 | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1274 (cmd, strs, as, bs) =
1276 '+':stuff -> rest AddModules stuff
1277 '-':stuff -> rest RemModules stuff
1278 stuff -> rest SetContext stuff
1280 rest cmd stuff = (cmd, strs, as, bs)
1281 where strs = words stuff
1282 (as,bs) = partitionWith starred strs
1284 sensible ('*':m) = looksLikeModuleName m
1285 sensible m = looksLikeModuleName m
1287 starred ('*':m) = Left m
1290 playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
1291 playCtxtCmd fail (cmd, as, bs)
1293 (as',bs') <- do_checks fail
1294 (prev_as,prev_bs) <- GHC.getContext
1298 prel_mod <- getPrelude
1299 let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
1303 let as_to_add = as' \\ (prev_as ++ prev_bs)
1304 bs_to_add = bs' \\ (prev_as ++ prev_bs)
1305 return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
1307 let new_as = prev_as \\ (as' ++ bs')
1308 new_bs = prev_bs \\ (as' ++ bs')
1309 return (new_as, new_bs)
1310 GHC.setContext new_as new_bs
1313 as' <- mapM wantInterpretedModule as
1314 bs' <- mapM lookupModule bs
1316 do_checks False = do
1317 as' <- mapM (trymaybe . wantInterpretedModule) as
1318 bs' <- mapM (trymaybe . lookupModule) bs
1319 return (catMaybes as', catMaybes bs')
1324 Left _ -> return Nothing
1325 Right a -> return (Just a)
1327 ----------------------------------------------------------------------------
1330 -- set options in the interpreter. Syntax is exactly the same as the
1331 -- ghc command line, except that certain options aren't available (-C,
1334 -- This is pretty fragile: most options won't work as expected. ToDo:
1335 -- figure out which ones & disallow them.
1337 setCmd :: String -> GHCi ()
1339 = do st <- getGHCiState
1340 let opts = options st
1341 io $ putStrLn (showSDoc (
1342 text "options currently set: " <>
1345 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1347 dflags <- getDynFlags
1348 io $ putStrLn (showSDoc (
1349 vcat (text "GHCi-specific dynamic flag settings:"
1350 :map (flagSetting dflags) ghciFlags)
1352 io $ putStrLn (showSDoc (
1353 vcat (text "other dynamic, non-language, flag settings:"
1354 :map (flagSetting dflags) nonLanguageDynFlags)
1356 where flagSetting dflags (str, f, _)
1357 | dopt f dflags = text " " <> text "-f" <> text str
1358 | otherwise = text " " <> text "-fno-" <> text str
1359 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
1361 nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
1363 flags = [Opt_PrintExplicitForalls
1364 ,Opt_PrintBindResult
1365 ,Opt_BreakOnException
1367 ,Opt_PrintEvldWithShow
1370 = case getCmd str of
1371 Right ("args", rest) ->
1373 Left err -> io (hPutStrLn stderr err)
1374 Right args -> setArgs args
1375 Right ("prog", rest) ->
1377 Right [prog] -> setProg prog
1378 _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
1379 Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
1380 Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
1381 Right ("stop", rest) -> setStop $ dropWhile isSpace rest
1382 _ -> case toArgs str of
1383 Left err -> io (hPutStrLn stderr err)
1384 Right wds -> setOptions wds
1386 setArgs, setOptions :: [String] -> GHCi ()
1387 setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
1391 setGHCiState st{ args = args }
1395 setGHCiState st{ progname = prog }
1399 setGHCiState st{ editor = cmd }
1401 setStop str@(c:_) | isDigit c
1402 = do let (nm_str,rest) = break (not.isDigit) str
1405 let old_breaks = breaks st
1406 if all ((/= nm) . fst) old_breaks
1407 then printForUser (text "Breakpoint" <+> ppr nm <+>
1408 text "does not exist")
1410 let new_breaks = map fn old_breaks
1411 fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
1412 | otherwise = (i,loc)
1413 setGHCiState st{ breaks = new_breaks }
1416 setGHCiState st{ stop = cmd }
1418 setPrompt value = do
1421 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1423 '\"' : _ -> case reads value of
1424 [(value', xs)] | all isSpace xs ->
1425 setGHCiState (st { prompt = value' })
1427 io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
1428 _ -> setGHCiState (st { prompt = value })
1431 do -- first, deal with the GHCi opts (+s, +t, etc.)
1432 let (plus_opts, minus_opts) = partitionWith isPlus wds
1433 mapM_ setOpt plus_opts
1434 -- then, dynamic flags
1435 newDynFlags minus_opts
1437 newDynFlags :: [String] -> GHCi ()
1438 newDynFlags minus_opts = do
1439 dflags <- getDynFlags
1440 let pkg_flags = packageFlags dflags
1441 (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
1442 handleFlagWarnings dflags' warns
1444 if (not (null leftovers))
1445 then ghcError $ errorsToGhcException leftovers
1448 new_pkgs <- setDynFlags dflags'
1450 -- if the package flags changed, we should reset the context
1451 -- and link the new packages.
1452 dflags <- getDynFlags
1453 when (packageFlags dflags /= pkg_flags) $ do
1454 io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
1456 _ <- GHC.load LoadAllTargets
1457 io (linkPackages dflags new_pkgs)
1458 -- package flags changed, we can't re-use any of the old context
1459 setContextAfterLoad ([],[]) False []
1463 unsetOptions :: String -> GHCi ()
1465 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1466 let opts = words str
1467 (minus_opts, rest1) = partition isMinus opts
1468 (plus_opts, rest2) = partitionWith isPlus rest1
1470 if (not (null rest2))
1471 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1474 mapM_ unsetOpt plus_opts
1476 let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1477 no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
1479 no_flags <- mapM no_flag minus_opts
1480 newDynFlags no_flags
1482 isMinus :: String -> Bool
1483 isMinus ('-':_) = True
1486 isPlus :: String -> Either String String
1487 isPlus ('+':opt) = Left opt
1488 isPlus other = Right other
1490 setOpt, unsetOpt :: String -> GHCi ()
1493 = case strToGHCiOpt str of
1494 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1495 Just o -> setOption o
1498 = case strToGHCiOpt str of
1499 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1500 Just o -> unsetOption o
1502 strToGHCiOpt :: String -> (Maybe GHCiOption)
1503 strToGHCiOpt "s" = Just ShowTiming
1504 strToGHCiOpt "t" = Just ShowType
1505 strToGHCiOpt "r" = Just RevertCAFs
1506 strToGHCiOpt _ = Nothing
1508 optToStr :: GHCiOption -> String
1509 optToStr ShowTiming = "s"
1510 optToStr ShowType = "t"
1511 optToStr RevertCAFs = "r"
1513 -- ---------------------------------------------------------------------------
1516 showCmd :: String -> GHCi ()
1520 ["args"] -> io $ putStrLn (show (args st))
1521 ["prog"] -> io $ putStrLn (show (progname st))
1522 ["prompt"] -> io $ putStrLn (show (prompt st))
1523 ["editor"] -> io $ putStrLn (show (editor st))
1524 ["stop"] -> io $ putStrLn (show (stop st))
1525 ["modules" ] -> showModules
1526 ["bindings"] -> showBindings
1527 ["linker"] -> io showLinkerState
1528 ["breaks"] -> showBkptTable
1529 ["context"] -> showContext
1530 ["packages"] -> showPackages
1531 ["languages"] -> showLanguages
1532 _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
1533 " | breaks | context | packages | languages ]"))
1535 showModules :: GHCi ()
1537 loaded_mods <- getLoadedModules
1538 -- we want *loaded* modules only, see #1734
1539 let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
1540 mapM_ show_one loaded_mods
1542 getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
1543 getLoadedModules = do
1544 graph <- GHC.getModuleGraph
1545 filterM (GHC.isLoaded . GHC.ms_mod_name) graph
1547 showBindings :: GHCi ()
1549 bindings <- GHC.getBindings
1550 docs <- pprTypeAndContents
1551 [ id | AnId id <- sortBy compareTyThings bindings]
1552 printForUserPartWay docs
1554 compareTyThings :: TyThing -> TyThing -> Ordering
1555 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1557 printTyThing :: TyThing -> GHCi ()
1558 printTyThing tyth = do dflags <- getDynFlags
1559 let pefas = dopt Opt_PrintExplicitForalls dflags
1560 printForUser (pprTyThing pefas tyth)
1562 showBkptTable :: GHCi ()
1565 printForUser $ prettyLocations (breaks st)
1567 showContext :: GHCi ()
1569 resumes <- GHC.getResumeContext
1570 printForUser $ vcat (map pp_resume (reverse resumes))
1573 ptext (sLit "--> ") <> text (GHC.resumeStmt resume)
1574 $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))
1576 showPackages :: GHCi ()
1578 pkg_flags <- fmap packageFlags getDynFlags
1579 io $ putStrLn $ showSDoc $ vcat $
1580 text ("active package flags:"++if null pkg_flags then " none" else "")
1581 : map showFlag pkg_flags
1582 pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1583 io $ putStrLn $ showSDoc $ vcat $
1584 text "packages currently loaded:"
1585 : map (nest 2 . text . packageIdString)
1586 (sortBy (compare `on` packageIdFS) pkg_ids)
1587 where showFlag (ExposePackage p) = text $ " -package " ++ p
1588 showFlag (HidePackage p) = text $ " -hide-package " ++ p
1589 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
1591 showLanguages :: GHCi ()
1593 dflags <- getDynFlags
1594 io $ putStrLn $ showSDoc $ vcat $
1595 text "active language flags:" :
1596 [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
1598 -- -----------------------------------------------------------------------------
1601 completeCmd, completeMacro, completeIdentifier, completeModule,
1602 completeHomeModule, completeSetOptions, completeShowOptions,
1603 completeHomeModuleOrFile, completeExpression
1604 :: CompletionFunc GHCi
1606 ghciCompleteWord :: CompletionFunc GHCi
1607 ghciCompleteWord line@(left,_) = case firstWord of
1608 ':':cmd | null rest -> completeCmd line
1610 completion <- lookupCompletion cmd
1612 "import" -> completeModule line
1613 _ -> completeExpression line
1615 (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
1616 lookupCompletion ('!':_) = return completeFilename
1617 lookupCompletion c = do
1618 maybe_cmd <- liftIO $ lookupCommand' c
1620 Just (_,_,f) -> return f
1621 Nothing -> return completeFilename
1623 completeCmd = wrapCompleter " " $ \w -> do
1624 cmds <- liftIO $ readIORef macros_ref
1625 return (filter (w `isPrefixOf`) (map (':':)
1626 (map cmdName (builtin_commands ++ cmds))))
1628 completeMacro = wrapIdentCompleter $ \w -> do
1629 cmds <- liftIO $ readIORef macros_ref
1630 return (filter (w `isPrefixOf`) (map cmdName cmds))
1632 completeIdentifier = wrapIdentCompleter $ \w -> do
1633 rdrs <- GHC.getRdrNamesInScope
1634 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1636 completeModule = wrapIdentCompleter $ \w -> do
1637 dflags <- GHC.getSessionDynFlags
1638 let pkg_mods = allExposedModules dflags
1639 loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
1640 return $ filter (w `isPrefixOf`)
1641 $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
1643 completeHomeModule = wrapIdentCompleter listHomeModules
1645 listHomeModules :: String -> GHCi [String]
1646 listHomeModules w = do
1647 g <- GHC.getModuleGraph
1648 let home_mods = map GHC.ms_mod_name g
1649 return $ sort $ filter (w `isPrefixOf`)
1650 $ map (showSDoc.ppr) home_mods
1652 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
1653 return (filter (w `isPrefixOf`) options)
1654 where options = "args":"prog":"prompt":"editor":"stop":flagList
1655 flagList = map head $ group $ sort allFlags
1657 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
1658 return (filter (w `isPrefixOf`) options)
1659 where options = ["args", "prog", "prompt", "editor", "stop",
1660 "modules", "bindings", "linker", "breaks",
1661 "context", "packages", "languages"]
1663 completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
1664 $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
1667 unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
1668 unionComplete f1 f2 line = do
1673 wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
1674 wrapCompleter breakChars fun = completeWord Nothing breakChars
1675 $ fmap (map simpleCompletion) . fmap sort . fun
1677 wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
1678 wrapIdentCompleter = wrapCompleter word_break_chars
1680 allExposedModules :: DynFlags -> [ModuleName]
1681 allExposedModules dflags
1682 = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1684 pkg_db = pkgIdMap (pkgState dflags)
1686 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
1689 -- ---------------------------------------------------------------------------
1690 -- User code exception handling
1692 -- This is the exception handler for exceptions generated by the
1693 -- user's code and exceptions coming from children sessions;
1694 -- it normally just prints out the exception. The
1695 -- handler must be recursive, in case showing the exception causes
1696 -- more exceptions to be raised.
1698 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1699 -- raising another exception. We therefore don't put the recursive
1700 -- handler arond the flushing operation, so if stderr is closed
1701 -- GHCi will just die gracefully rather than going into an infinite loop.
1702 handler :: SomeException -> GHCi Bool
1704 handler exception = do
1706 io installSignalHandlers
1707 ghciHandle handler (showException exception >> return False)
1709 showException :: SomeException -> GHCi ()
1711 io $ case fromException se of
1712 Just Interrupted -> putStrLn "Interrupted."
1713 -- omit the location for CmdLineError:
1714 Just (CmdLineError s) -> putStrLn s
1716 Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
1717 Just other_ghc_ex -> print other_ghc_ex
1718 Nothing -> putStrLn ("*** Exception: " ++ show se)
1720 -----------------------------------------------------------------------------
1721 -- recursive exception handlers
1723 -- Don't forget to unblock async exceptions in the handler, or if we're
1724 -- in an exception loop (eg. let a = error a in a) the ^C exception
1725 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1727 ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a
1728 ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)
1730 ghciTry :: GHCi a -> GHCi (Either SomeException a)
1731 ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
1733 -- ----------------------------------------------------------------------------
1736 -- TODO: won't work if home dir is encoded.
1737 -- (changeDirectory may not work either in that case.)
1738 expandPath :: MonadIO m => String -> InputT m String
1739 expandPath path = do
1740 exp_path <- liftIO $ expandPathIO path
1741 enc <- fmap BS.unpack $ Encoding.encode exp_path
1744 expandPathIO :: String -> IO String
1746 case dropWhile isSpace path of
1748 tilde <- getHomeDirectory -- will fail if HOME not defined
1749 return (tilde ++ '/':d)
1753 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
1754 wantInterpretedModule str = do
1755 modl <- lookupModule str
1756 dflags <- getDynFlags
1757 when (GHC.modulePackageId modl /= thisPackage dflags) $
1758 ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
1759 is_interpreted <- GHC.moduleIsInterpreted modl
1760 when (not is_interpreted) $
1761 ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
1764 wantNameFromInterpretedModule :: GHC.GhcMonad m
1765 => (Name -> SDoc -> m ())
1769 wantNameFromInterpretedModule noCanDo str and_then =
1770 handleSourceError (GHC.printExceptionAndWarnings) $ do
1771 names <- GHC.parseName str
1775 let modl = ASSERT( isExternalName n ) GHC.nameModule n
1776 if not (GHC.isExternalName n)
1777 then noCanDo n $ ppr n <>
1778 text " is not defined in an interpreted module"
1780 is_interpreted <- GHC.moduleIsInterpreted modl
1781 if not is_interpreted
1782 then noCanDo n $ text "module " <> ppr modl <>
1783 text " is not interpreted"
1786 -- -----------------------------------------------------------------------------
1787 -- commands for debugger
1789 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1790 sprintCmd = pprintCommand False False
1791 printCmd = pprintCommand True False
1792 forceCmd = pprintCommand False True
1794 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1795 pprintCommand bind force str = do
1796 pprintClosureCommand bind force str
1798 stepCmd :: String -> GHCi ()
1799 stepCmd [] = doContinue (const True) GHC.SingleStep
1800 stepCmd expression = runStmt expression GHC.SingleStep >> return ()
1802 stepLocalCmd :: String -> GHCi ()
1803 stepLocalCmd [] = do
1804 mb_span <- getCurrentBreakSpan
1806 Nothing -> stepCmd []
1808 Just mod <- getCurrentBreakModule
1809 current_toplevel_decl <- enclosingTickSpan mod loc
1810 doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1812 stepLocalCmd expression = stepCmd expression
1814 stepModuleCmd :: String -> GHCi ()
1815 stepModuleCmd [] = do
1816 mb_span <- getCurrentBreakSpan
1818 Nothing -> stepCmd []
1820 Just span <- getCurrentBreakSpan
1821 let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
1822 doContinue f GHC.SingleStep
1824 stepModuleCmd expression = stepCmd expression
1826 -- | Returns the span of the largest tick containing the srcspan given
1827 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1828 enclosingTickSpan mod src = do
1829 ticks <- getTickArray mod
1830 let line = srcSpanStartLine src
1831 ASSERT (inRange (bounds ticks) line) do
1832 let enclosing_spans = [ span | (_,span) <- ticks ! line
1833 , srcSpanEnd span >= srcSpanEnd src]
1834 return . head . sortBy leftmost_largest $ enclosing_spans
1836 traceCmd :: String -> GHCi ()
1837 traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
1838 traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()
1840 continueCmd :: String -> GHCi ()
1841 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1843 -- doContinue :: SingleStep -> GHCi ()
1844 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1845 doContinue pred step = do
1846 runResult <- resume pred step
1847 _ <- afterRunStmt pred runResult
1850 abandonCmd :: String -> GHCi ()
1851 abandonCmd = noArgs $ do
1852 b <- GHC.abandon -- the prompt will change to indicate the new context
1853 when (not b) $ io $ putStrLn "There is no computation running."
1856 deleteCmd :: String -> GHCi ()
1857 deleteCmd argLine = do
1858 deleteSwitch $ words argLine
1860 deleteSwitch :: [String] -> GHCi ()
1862 io $ putStrLn "The delete command requires at least one argument."
1863 -- delete all break points
1864 deleteSwitch ("*":_rest) = discardActiveBreakPoints
1865 deleteSwitch idents = do
1866 mapM_ deleteOneBreak idents
1868 deleteOneBreak :: String -> GHCi ()
1870 | all isDigit str = deleteBreak (read str)
1871 | otherwise = return ()
1873 historyCmd :: String -> GHCi ()
1875 | null arg = history 20
1876 | all isDigit arg = history (read arg)
1877 | otherwise = io $ putStrLn "Syntax: :history [num]"
1880 resumes <- GHC.getResumeContext
1882 [] -> io $ putStrLn "Not stopped at a breakpoint"
1884 let hist = GHC.resumeHistory r
1885 (took,rest) = splitAt num hist
1887 [] -> io $ putStrLn $
1888 "Empty history. Perhaps you forgot to use :trace?"
1890 spans <- mapM GHC.getHistorySpan took
1891 let nums = map (printf "-%-3d:") [(1::Int)..]
1892 names = map GHC.historyEnclosingDecl took
1893 printForUser (vcat(zipWith3
1894 (\x y z -> x <+> y <+> z)
1896 (map (bold . ppr) names)
1897 (map (parens . ppr) spans)))
1898 io $ putStrLn $ if null rest then "<end of history>" else "..."
1900 bold :: SDoc -> SDoc
1901 bold c | do_bold = text start_bold <> c <> text end_bold
1904 backCmd :: String -> GHCi ()
1905 backCmd = noArgs $ do
1906 (names, _, span) <- GHC.back
1907 printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
1908 printTypeOfNames names
1909 -- run the command set with ":set stop <cmd>"
1911 enqueueCommands [stop st]
1913 forwardCmd :: String -> GHCi ()
1914 forwardCmd = noArgs $ do
1915 (names, ix, span) <- GHC.forward
1916 printForUser $ (if (ix == 0)
1917 then ptext (sLit "Stopped at")
1918 else ptext (sLit "Logged breakpoint at")) <+> ppr span
1919 printTypeOfNames names
1920 -- run the command set with ":set stop <cmd>"
1922 enqueueCommands [stop st]
1924 -- handle the "break" command
1925 breakCmd :: String -> GHCi ()
1926 breakCmd argLine = do
1927 breakSwitch $ words argLine
1929 breakSwitch :: [String] -> GHCi ()
1931 io $ putStrLn "The break command requires at least one argument."
1932 breakSwitch (arg1:rest)
1933 | looksLikeModuleName arg1 && not (null rest) = do
1934 mod <- wantInterpretedModule arg1
1935 breakByModule mod rest
1936 | all isDigit arg1 = do
1937 (toplevel, _) <- GHC.getContext
1939 (mod : _) -> breakByModuleLine mod (read arg1) rest
1941 io $ putStrLn "Cannot find default module for breakpoint."
1942 io $ putStrLn "Perhaps no modules are loaded for debugging?"
1943 | otherwise = do -- try parsing it as an identifier
1944 wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1945 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1946 if GHC.isGoodSrcLoc loc
1947 then ASSERT( isExternalName name )
1948 findBreakAndSet (GHC.nameModule name) $
1949 findBreakByCoord (Just (GHC.srcLocFile loc))
1950 (GHC.srcLocLine loc,
1952 else noCanDo name $ text "can't find its location: " <> ppr loc
1954 noCanDo n why = printForUser $
1955 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1957 breakByModule :: Module -> [String] -> GHCi ()
1958 breakByModule mod (arg1:rest)
1959 | all isDigit arg1 = do -- looks like a line number
1960 breakByModuleLine mod (read arg1) rest
1964 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1965 breakByModuleLine mod line args
1966 | [] <- args = findBreakAndSet mod $ findBreakByLine line
1967 | [col] <- args, all isDigit col =
1968 findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1969 | otherwise = breakSyntax
1972 breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1974 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1975 findBreakAndSet mod lookupTickTree = do
1976 tickArray <- getTickArray mod
1977 (breakArray, _) <- getModBreak mod
1978 case lookupTickTree tickArray of
1979 Nothing -> io $ putStrLn $ "No breakpoints found at that location."
1980 Just (tick, span) -> do
1981 success <- io $ setBreakFlag True breakArray tick
1985 recordBreak $ BreakLocation
1992 text "Breakpoint " <> ppr nm <>
1994 then text " was already set at " <> ppr span
1995 else text " activated at " <> ppr span
1997 printForUser $ text "Breakpoint could not be activated at"
2000 -- When a line number is specified, the current policy for choosing
2001 -- the best breakpoint is this:
2002 -- - the leftmost complete subexpression on the specified line, or
2003 -- - the leftmost subexpression starting on the specified line, or
2004 -- - the rightmost subexpression enclosing the specified line
2006 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
2007 findBreakByLine line arr
2008 | not (inRange (bounds arr) line) = Nothing
2010 listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
2011 listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
2012 listToMaybe (sortBy (rightmost `on` snd) ticks)
2016 starts_here = [ tick | tick@(_,span) <- ticks,
2017 GHC.srcSpanStartLine span == line ]
2019 (complete,incomplete) = partition ends_here starts_here
2020 where ends_here (_,span) = GHC.srcSpanEndLine span == line
2022 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
2023 -> Maybe (BreakIndex,SrcSpan)
2024 findBreakByCoord mb_file (line, col) arr
2025 | not (inRange (bounds arr) line) = Nothing
2027 listToMaybe (sortBy (rightmost `on` snd) contains ++
2028 sortBy (leftmost_smallest `on` snd) after_here)
2032 -- the ticks that span this coordinate
2033 contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
2034 is_correct_file span ]
2036 is_correct_file span
2037 | Just f <- mb_file = GHC.srcSpanFile span == f
2040 after_here = [ tick | tick@(_,span) <- ticks,
2041 GHC.srcSpanStartLine span == line,
2042 GHC.srcSpanStartCol span >= col ]
2044 -- For now, use ANSI bold on terminals that we know support it.
2045 -- Otherwise, we add a line of carets under the active expression instead.
2046 -- In particular, on Windows and when running the testsuite (which sets
2047 -- TERM to vt100 for other reasons) we get carets.
2048 -- We really ought to use a proper termcap/terminfo library.
2050 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2051 where mTerm = System.Environment.getEnv "TERM"
2052 `catchIO` \_ -> return "TERM not set"
2054 start_bold :: String
2055 start_bold = "\ESC[1m"
2057 end_bold = "\ESC[0m"
2059 listCmd :: String -> InputT GHCi ()
2061 mb_span <- lift getCurrentBreakSpan
2064 printForUser' $ text "Not stopped at a breakpoint; nothing to list"
2066 | GHC.isGoodSrcSpan span -> listAround span True
2068 do resumes <- GHC.getResumeContext
2070 [] -> panic "No resumes"
2072 do let traceIt = case GHC.resumeHistory r of
2073 [] -> text "rerunning with :trace,"
2075 doWhat = traceIt <+> text ":back then :list"
2076 printForUser' (text "Unable to list source for" <+>
2078 $$ text "Try" <+> doWhat)
2079 listCmd str = list2 (words str)
2081 list2 :: [String] -> InputT GHCi ()
2082 list2 [arg] | all isDigit arg = do
2083 (toplevel, _) <- GHC.getContext
2085 [] -> outputStrLn "No module to list"
2086 (mod : _) -> listModuleLine mod (read arg)
2087 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2088 mod <- wantInterpretedModule arg1
2089 listModuleLine mod (read arg2)
2091 wantNameFromInterpretedModule noCanDo arg $ \name -> do
2092 let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2093 if GHC.isGoodSrcLoc loc
2095 tickArray <- ASSERT( isExternalName name )
2096 lift $ getTickArray (GHC.nameModule name)
2097 let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2098 (GHC.srcLocLine loc, GHC.srcLocCol loc)
2101 Nothing -> listAround (GHC.srcLocSpan loc) False
2102 Just (_,span) -> listAround span False
2104 noCanDo name $ text "can't find its location: " <>
2107 noCanDo n why = printForUser' $
2108 text "cannot list source code for " <> ppr n <> text ": " <> why
2110 outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
2112 listModuleLine :: Module -> Int -> InputT GHCi ()
2113 listModuleLine modl line = do
2114 graph <- GHC.getModuleGraph
2115 let this = filter ((== modl) . GHC.ms_mod) graph
2117 [] -> panic "listModuleLine"
2119 let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
2120 loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2121 listAround (GHC.srcLocSpan loc) False
2123 -- | list a section of a source file around a particular SrcSpan.
2124 -- If the highlight flag is True, also highlight the span using
2125 -- start_bold\/end_bold.
2127 -- GHC files are UTF-8, so we can implement this by:
2128 -- 1) read the file in as a BS and syntax highlight it as before
2129 -- 2) convert the BS to String using utf-string, and write it out.
2130 -- It would be better if we could convert directly between UTF-8 and the
2131 -- console encoding, of course.
2132 listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
2133 listAround span do_highlight = do
2134 contents <- liftIO $ BS.readFile (unpackFS file)
2136 lines = BS.split '\n' contents
2137 these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2138 drop (line1 - 1 - pad_before) $ lines
2139 fst_line = max 1 (line1 - pad_before)
2140 line_nos = [ fst_line .. ]
2142 highlighted | do_highlight = zipWith highlight line_nos these_lines
2143 | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
2145 bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
2146 prefixed = zipWith ($) highlighted bs_line_nos
2148 let output = BS.intercalate (BS.pack "\n") prefixed
2149 utf8Decoded <- liftIO $ BS.useAsCStringLen output
2150 $ \(p,n) -> utf8DecodeString (castPtr p) n
2151 outputStrLn utf8Decoded
2153 file = GHC.srcSpanFile span
2154 line1 = GHC.srcSpanStartLine span
2155 col1 = GHC.srcSpanStartCol span
2156 line2 = GHC.srcSpanEndLine span
2157 col2 = GHC.srcSpanEndCol span
2159 pad_before | line1 == 1 = 0
2163 highlight | do_bold = highlight_bold
2164 | otherwise = highlight_carets
2166 highlight_bold no line prefix
2167 | no == line1 && no == line2
2168 = let (a,r) = BS.splitAt col1 line
2169 (b,c) = BS.splitAt (col2-col1) r
2171 BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2173 = let (a,b) = BS.splitAt col1 line in
2174 BS.concat [prefix, a, BS.pack start_bold, b]
2176 = let (a,b) = BS.splitAt col2 line in
2177 BS.concat [prefix, a, BS.pack end_bold, b]
2178 | otherwise = BS.concat [prefix, line]
2180 highlight_carets no line prefix
2181 | no == line1 && no == line2
2182 = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2183 BS.replicate (col2-col1) '^']
2185 = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2188 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2190 | otherwise = BS.concat [prefix, line]
2192 indent = BS.pack (" " ++ replicate (length (show no)) ' ')
2193 nl = BS.singleton '\n'
2195 -- --------------------------------------------------------------------------
2198 getTickArray :: Module -> GHCi TickArray
2199 getTickArray modl = do
2201 let arrmap = tickarrays st
2202 case lookupModuleEnv arrmap modl of
2203 Just arr -> return arr
2205 (_breakArray, ticks) <- getModBreak modl
2206 let arr = mkTickArray (assocs ticks)
2207 setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2210 discardTickArrays :: GHCi ()
2211 discardTickArrays = do
2213 setGHCiState st{tickarrays = emptyModuleEnv}
2215 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2217 = accumArray (flip (:)) [] (1, max_line)
2218 [ (line, (nm,span)) | (nm,span) <- ticks,
2219 line <- srcSpanLines span ]
2221 max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2222 srcSpanLines span = [ GHC.srcSpanStartLine span ..
2223 GHC.srcSpanEndLine span ]
2225 lookupModule :: GHC.GhcMonad m => String -> m Module
2226 lookupModule modName
2227 = GHC.lookupModule (GHC.mkModuleName modName) Nothing
2229 -- don't reset the counter back to zero?
2230 discardActiveBreakPoints :: GHCi ()
2231 discardActiveBreakPoints = do
2233 mapM_ (turnOffBreak.snd) (breaks st)
2234 setGHCiState $ st { breaks = [] }
2236 deleteBreak :: Int -> GHCi ()
2237 deleteBreak identity = do
2239 let oldLocations = breaks st
2240 (this,rest) = partition (\loc -> fst loc == identity) oldLocations
2242 then printForUser (text "Breakpoint" <+> ppr identity <+>
2243 text "does not exist")
2245 mapM_ (turnOffBreak.snd) this
2246 setGHCiState $ st { breaks = rest }
2248 turnOffBreak :: BreakLocation -> GHCi Bool
2249 turnOffBreak loc = do
2250 (arr, _) <- getModBreak (breakModule loc)
2251 io $ setBreakFlag False arr (breakTick loc)
2253 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2254 getModBreak mod = do
2255 Just mod_info <- GHC.getModuleInfo mod
2256 let modBreaks = GHC.modInfoModBreaks mod_info
2257 let array = GHC.modBreaks_flags modBreaks
2258 let ticks = GHC.modBreaks_locs modBreaks
2259 return (array, ticks)
2261 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2262 setBreakFlag toggle array index
2263 | toggle = GHC.setBreakOn array index
2264 | otherwise = GHC.setBreakOff array index